How to save a TObjectList in a Tstream - delphi

I need to save a TObjectList<TStrings> (or <TStringList>) in a TStream and then retrive it.
To be clear, how to apply SaveToStream and LoadFromStream to a TObjectList?

Try something like this:
procedure SaveListOfStringsToStream(List: TObjectList<TStrings>; Stream: TStream);
var
Count, I: Integer;
MStrm: TMemoryStream;
Size: Int64;
begin
Count := List.Count;
Stream.WriteBuffer(Count, SizeOf(Count));
if Count = 0 then Exit;
MStrm := TMemoryStream.Create;
try
for I := 0 to Count-1 do
begin
List[I].SaveToStream(MStrm);
Size := MStrm.Size;
Stream.WriteBuffer(Size, SizeOf(Size));
Stream.CopyFrom(MStrm, 0);
MStrm.Clear;
end;
finally
MStrm.Free;
end;
end;
procedure LoadListOfStringsFromStream(List: TObjectList<TStrings>; Stream: TStream);
var
Count, I: Integer;
MStrm: TMemoryStream;
Size: Int64;
SList: TStringList;
begin
Stream.ReadBuffer(Count, SizeOf(Count));
if Count <= 0 then Exit;
MStrm := TMemoryStream.Create;
try
for I := 0 to Count-1 do
begin
Stream.ReadBuffer(Size, SizeOf(Size));
SList := TStringList.Create;
try
if Size > 0 then
begin
MStrm.CopyFrom(Stream, Size);
MStrm.Position := 0;
SList.LoadFromStream(MStrm);
MStrm.Clear;
end;
List.Add(SList);
except
SList.Free;
raise;
end;
end;
finally
MStrm.Free;
end;
end;
Alternatively:
procedure SaveListOfStringsToStream(List: TObjectList<TStrings>; Stream: TStream);
var
LCount, SCount, Len, I, J: Integer;
SList: TStrings;
S: UTF8String;
begin
LCount := List.Count;
Stream.WriteBuffer(LCount, SizeOf(LCount));
if LCount = 0 then Exit;
for I := 0 to LCount-1 do
begin
SList := List[I];
SCount := SList.Count;
Stream.WriteBuffer(SCount, SizeOf(SCount));
for J := 0 to SCount-1 do
begin
S := UTF8String(SList[J]);
// or, if using Delphi 2007 or earlier:
// S := UTF8Encode(SList[J]);
Len := Length(S);
Stream.WriteBuffer(Len, SizeOf(Len));
Stream.WriteBuffer(PAnsiChar(S)^, Len * SizeOf(AnsiChar));
end;
end;
end;
procedure LoadListOfStringsFromStream(List: TObjectList<TStrings>; Stream: TStream);
var
LCount, SCount, Len, I, J: Integer;
SList: TStrings;
S: UTF8String;
begin
Stream.ReadBuffer(LCount, SizeOf(LCount));
for I := 0 to LCount-1 do
begin
Stream.ReadBuffer(SCount, SizeOf(SCount));
SList := TStringList.Create;
try
for J := 0 to SCount-1 do
begin
Stream.ReadBuffer(Len, SizeOf(Len));
SetLength(S, Len);
Stream.ReadBuffer(PAnsiChar(S)^, Len * SizeOf(AnsiChar));
SList.Add(String(S));
// or, if using Delphi 2007 or earlier:
// SList.Add(UTF8Decode(S));
end;
List.Add(SList);
except
SList.Free;
raise;
end;
end;
end;

What's in your list?
It depends on what type of objects you have in your objectlist.
You loop over the list and save each item in turn.
However the objects inside your list need to have a SaveToStream method.
For reasons unknown SaveToStream is not a method of TPersistent, instead it is implemented independently in different classes.
Test for stream support
If the VCL were built with interfaces in mind, in newer versions has been solved with the IStreamPersist interface.
If all your stuff in the list descents from a base class that has streaming built-in (e.g. TComponent) then there is no problem and you can just use TComponent.SaveToStream.
type
TStreamableClass = TStrings; //just to show that this does not depend on TStrings.
procedure SaveToStream(List: TObjectList; Stream: TStream);
var
i: integer;
begin
for i:= 0 to List.Count -1 do begin
if List[i] is TStreamableClass then begin
TStreamableClass(List[i]).SaveToStream(Stream);
end;
end; {for i}
end;
Add stream support
If you have items in your list that do not derive from a common streamable ancestor then you'll have to have multiple if list[i] is TX tests in your loop.
If the object does not have a SaveToStream method, but you have enough knowledge of the class to implement it yourself, then you have twothree options.
A: implement a class helper that adds SaveToStream to that class or B: add a descendent class that implements that option.
If these are your own objects, then see option C: below.
type
TObjectXStreamable = class(TObjectX)
public
procedure SaveToStream(Stream: TStream); virtual;
procedure LoadFromStream(Stream: TStream); virtual;
end;
procedure SaveToStream(List: TObjectList; Stream: TStream);
...
if List[i] is TObjectX then TObjectXStreamable(List[i]).SaveToStream(Stream);
...
Note that this approach fails if TObjectX has subclasses with additional data. The added streaming will not know about this extra data.
Option C: implement System.Classes.IStreamPersist
type
IStreamPersist = interface
['<GUID>']
procedure SaveToStream(Stream: TStream);
procedure LoadFromStream(Stream: TStream);
end;
//enhance your streamable objects like so:
TInterfaceBaseObject = TInterfacedObject //or TSingletonImplementation
TMyObject = class(TInterfaceBaseObject, IStreamPersist)
procedure SaveToStream(Stream: TStream); virtual;
procedure LoadFromStream(Stream: TStream); virtual;
See: Bypassing (disabling) Delphi's reference counting for interfaces
You test the IStreamPersist support using the supports call.
if Supports(List[i], IStreamPersist) then (List[i] as IStreamPersist).SaveToStream(Stream);
If you have a newer version of Delphi consider using a generic TObjectList, that way you can limit your list to: MyList: TObjectList<TComponent>;
Now you can just call MyList[i].SaveToStream, because Delphi knows that the list only contains (descendents of) TComponent.

You will need to create your own routine to do this: One for saving, the other for loading.
For saving, loop through the list, convert each pointer of the list into is hexadecimal (decimal, octal) then add a separator character like ','; When done write the string contain to the stream.
For loading, loop through the list, search for the first separator character, extract the value, convert it back as a pointer then add it to the list.
Procedure ObjListToStream(objList: TObjectList; aStream: TStream);
var
str: String;
iCnt: Integer;
Begin
if not assigned(aStream) then exit; {or raise exception}
for iCnt := 0 to objList.Count - 1 do
begin
str := str + IntToStr(Integer(objList.Items[iCnt])) + ',';
end;
aStream.Write(str[1], Length(str));
End;
Procedure StreamToObjList(objList: TObjectList; aList: String);
var
str: String;
iCnt: Integer;
iStart, iStop: Integer;
Begin
try
if not assigned(aStream) then exit; {or raise exception}
iStart := 0;
Repeat
iStop := Pos(',', aList, iStart);
if iStop > 0 then
begin
objList.Add(StrToInt(Copy(sList, iStart, iStop - iStart)));
iStart := iStop + 1;
end;
Until iStop = 0;
except
{something want wrong}
end;
End;
I haven't test it and wrote it from memory. But it should point you in the right direction.

Related

Possible to loop only declared properties of a class?

The extended RTTI has the GetDeclaredProperties function which is exactly what i need, however i faced problems if i use the extended RTTI in multi-threading.
Therefore, i used GetPropList, but this gives me a list of all properties - not only published in the current class (or explicit stated).
i.e.
TBaseSettings = class(TPersistent)
published
property Charset: string read FCharset write FCharset;
end;
TBasicSettings = class(TBaseSettings)
published
property forums: Variant read fforums write fforums;
end;
TConcreteSettings = class(TBasicSettings)
published
property forums; // <-- make it explicit visible: OK
property prefix: Variant read fprefix write fprefix; // <-- OK
end;
I don't want to read the Charset property.
My first guess was to use a modified version of https://stackoverflow.com/a/1565686 to check for inheritance, but actually the forums property is also inherited.
Maybe this is not possible with the classic RTTI? I use Delphi 2010.
In case it's convenient to have your code calling GetDeclaredPropList in a similar way to calling GetPropList, see below.
Edit: I've rewritten the code in Delphi 7 and I believe it should work in Delphi 2010, too (which I don't have at hand).
type
PPropData = ^TPropData;
function AfterString(P: Pointer): Pointer;
begin
Result := Pointer(NativeUInt(P) + (PByte(P)^ + 1));
end;
function GetPropData(TypeData: PTypeData): PPropData;
begin
Result := AfterString(#TypeData^.UnitName);
end;
function NextPropInfo(PropInfo: PPropInfo): PPropInfo;
begin
Result := AfterString(#PropInfo^.Name);
end;
procedure GetDeclaredPropInfos(TypeInfo: PTypeInfo; PropList: PPropList);
var
TypeData: PTypeData;
PropData: PPropData;
PropInfo: PPropInfo;
I: Integer;
begin
TypeData := GetTypeData(TypeInfo);
PropData := GetPropData(TypeData);
FillChar(PropList^, Sizeof(PPropInfo) * PropData^.PropCount, 0);
PropInfo := PPropInfo(#PropData^.PropList);
for I := 0 to PropData^.PropCount - 1 do
begin
PropList^[I] := PropInfo;
PropInfo := NextPropInfo(PropInfo);
end;
end;
function GetDeclaredPropList(TypeInfo: PTypeInfo; out PropList: PPropList): Integer; overload;
begin
Result := GetPropData(GetTypeData(TypeInfo))^.PropCount;
if Result > 0 then
begin
GetMem(PropList, Result * SizeOf(Pointer));
GetDeclaredPropInfos(TypeInfo, PropList);
end;
end;
function GetDeclaredPropList(AObject: TObject; out PropList: PPropList): Integer; overload;
begin
Result := GetDeclaredPropList(PTypeInfo(AObject.ClassInfo), PropList);
end;
// example usage:
var
I, Count: Integer;
PropList: PPropList;
PropInfo: PPropInfo;
begin
Count := GetDeclaredPropList(TypeInfo(TConcreteSettings), PropList);
try
for I := 0 to Count - 1 do
begin
PropInfo := PropList^[I];
Writeln(PropInfo^.Name);
end;
finally
FreeMem(PropList);
end;
end.
var
TypeData: PTypeData;
PropData: PPropData;
PropInfo: PPropInfo;
I: Integer;
begin
TypeData := GetTypeData(TypeInfo(TConcreteSettings));
PropData := GetPropData(TypeData);
if Assigned(PropData) then
begin
PropInfo := #PropData^.PropList;
for I := 0 to PropData^.PropCount - 1 do
begin
Writeln(PropInfo^.Name);
PropInfo := NextPropInfo(PropInfo);
end;
end;
end;
For implementation of GetPropData and NextPropInfo see my other answer above.

Leak Watcher Tool - Overloading the memory allocation

I'm developing a Tool to help me find memory leak on my application.
The feature runs well while I'm working with object (TOBJECT), but I'm getting some problems while I'm working with buffer.
In SOME cases, that I could not identify I got some errors in my application, this errors seems to be some bad access to memory. I could not find any possible error on my logic or my code. If some one with more experience with Delphi can help me. Maybe some memory manager particular behavior is causing the problem.
A little more explanations:
Memory Allocation Control
Objective: Count how much memory buffer with determined size is all allocated by the system, exemple:
Buffer Size | Amount of Allocs | Total Memory Used
325 | 35265 | 11461125
23 | 32 | 736
... | ... | ...
How I control the memory allocation and deallocation:
I created an array of integer that goes from 0 to 65365. This array will be used to keep the amount of allocs of the corresponding size.
For example, If I call GetMem for a buffer of 523, the Array[523] will increase + 1.
The GetMem, ReallocMem, AllocMem, the problem is easy to resolve 'cause one of it's parameters is the size of the buffer. So I can use this to increase the position of the array.
The problem cames with the FreeMem, 'cause the only parameter is the pointer of the buffer. I don't know it's size.
- I can't create a list to keep the Pointer and it's size. 'Cause there is SO much allocations, it will be so much expensive to the application keep searching/adding/removing items from this list. And this list must to be protected with critical section etc etc. So no way.
How I'm trying to solve this problem:
Just to remeber I created the array to keep the number off allocations.
Items: 0 65365
|................................|
Addess: $X $(65365x SizeOf(Integer))
When allocators methos are called, for example: GetMem(52);
I changed the behavior of it, I will alloc the requested size (52), but I'll add here a size of an integer;
So I will have:
0 4 56
|.....|...........................|
$x
In the plus space (0..3) I'll set the address of the corresponding space of the array. In this case the address position $array(52). And I add + (SizeOf(Integer)) to the address result of the GetMem, so it will have access just the 52 bytes that were asked for.
When the FreeMem are called. What I do is:
- Get the pointer asked for deallocation.
- Decrease the pointer by the size of the integer
- Check if the address of the current pointer is relative to the Array of control address.
- If it is, I use the the address and decrease 1 from the Array position
- And ask for the FreeMem
In the biggest part of time and systems it's working very well. BUT, In some moments that I really don't know how and were I get some strange errors in system. Erros that I NEVER get if I deactive this implementation.
I'm commenting the code to get easier to be understood, but It's not a hard code so, here it's:
Other thread in: https://forums.embarcadero.com/thread.jspa?threadID=77787
unit uInstancesAnalyser;
{
Functionality: The feature developed in this unit try to watch how the memory are being allocated by your system. The main focus of it is help to find memory leak in the most non intrusive way.
How to Install: Put this unit as the first unit of yout project. If use use a third memory manager put this unit just after the unit of your memory manager.
How to get it's report: It's not the final version of this unit, so the viewer was not developed. By the momento you can call the
method SaveInstancesToFile. It'll create a text file called MemReport in the executable path.
WARNING: If you use the pointer of the VMT destinated to vmtAutoTable, you should not use the directive TRACEINSTANCES.
How it works:
The feature work in two different approaches:
1) Map the memory usage by objects
2) Map the memory usage by buffers (Records, strings and so on)
How are Objects tracked:
The TObject.NewInstance was replaced by a new method (TObjectHack.NNewInstanceTrace).
So when the creation of an object is called it's redirect to the new method. In this new method is increased the counter of the relative class and change the method in the VMT that is responsible to free the object to a new destructor method (vmtFreeInstance). This new destructor call the decrease of the counter and the old destructor.
This way I can know how much of objects of each class are alive in the system.
(More details about how it deep work can be found in the comments on the code)
How are Memory Buffer Traced:
The GetMem, FreeMem, ReallocMem, AllocMem were replaced by new method that have an special behavior to help track the buffers.
As the memory allocation use the same method to every kind of memory request, I'm not able to create a single counter to each count of buffer. So, I calculate them base on it size. First I create a array of integer that start on 0 and goes to 65365.
When the system ask me to give it a buffer of 65 bytes, I increase the position 65 of the array and the buffer is deallocated I call the decrease of the position of the array corresponding to buffer size. If the size requested to the buffer is bigger or equal to 65365, I'll use the position 65365 of the array.
(More details about how it deep work can be found in the comments on the code)
--------------------------------------------------------------------------------------
Develop by Rodrigo Farias Rezino
E-mail: rodrigofrezino#gmail.com
Stackoverflow: http://stackoverflow.com/users/225010/saci
Please, any bug let me know
}
interface
{$DEFINE TRACEBUFFER} {Directive used to track buffer} //Comment to inactive
{$DEFINE TRACEINSTANCES} {Directive used to track objects} //Comment to inactive
//{$DEFINE WATCHTHREADS} // It's not finished
uses
Classes, SyncObjs, uIntegerList;
{You can register possibles names for some Buffers Sizes, it can be useful when you are working with record. Example
TRecordTest = record
Field1: Integer
Field2: string[50]
So, you can call RegisterNamedBuffer(TRecordTest, SizeOf(TRecordTest));
This way, in on the report of buffer/objects will be explicit what possibles named buffer can be that memory in use.}
procedure RegisterNamedBuffer(ABufferName: string; ASize: integer);
{This function return the possible named buffers registered with that size}
function GetBufferName(ASize: integer): string;
{It's a simple output to save the report of memory usage on the disk. It'll create a file called test.txt in the executable directory}
procedure SaveInstancesToFile;
var
{Flag to say if the memory watcher is on or off}
SIsMemoryWatcherActive: Boolean;
implementation
uses
Windows, SysUtils, TypInfo;
const
SIZE_OF_INT = SizeOf(Integer);
SIZE_OF_MAP = 65365;
{$IFDEF WATCHTHREADS}
GAP_SIZE = SIZE_OF_INT * 2;
{$ELSE}
GAP_SIZE = SIZE_OF_INT;
{$ENDIF}
type
TArrayOfMap = array [0..SIZE_OF_MAP] of Integer;
TThreadMemory = array [0..SIZE_OF_MAP] of Integer;
{This class is used to Register}
TNamedBufferList = class(TIntegerList)
public
constructor Create;
function GetBufferName(ASize: integer): string;
procedure RegisterNamedBuffer(ABufferName: string; ASize: integer);
end;
PClassVars = ^TClassVars;
TClassVars = class(TObject)
private
class var ListClassVars: TList;
public
BaseInstanceCount: Integer;
BaseClassName: string;
BaseParentClassName: string;
BaseInstanceSize: Integer;
OldVMTFreeInstance: Pointer;
constructor Create;
class procedure SaveToDisk;
end;
TNamedBuffer = class(TObject)
Names: string;
end;
PJump = ^TJump;
TJump = packed record
OpCode: Byte;
Distance: Pointer;
end;
TObjectHack = class(TObject)
private
FCriticalSection: TCriticalSection;
class procedure SetClassVars(AClassVars: TClassVars); //inline;
class function GetClassVars: TClassVars; inline;
procedure IncCounter; inline;
procedure DecCounter; inline;
procedure CallOldFunction;
public
constructor Create;
destructor Destroy; override;
class function NNewInstance: TObject;
class function NNewInstanceTrace: TObject;
procedure NFreeInstance;
end;
var
SDefaultGetMem: function(Size: Integer): Pointer;
SDefaultFreeMem: function(P: Pointer): Integer;
SDefaultReallocMem: function(P: Pointer; Size: Integer): Pointer;
SDefaultAllocMem: function(Size: Cardinal): Pointer;
SThreadMemory: TThreadMemory;
SMap: TArrayOfMap;
SNamedBufferList: TNamedBufferList;
{$IFDEF WATCHTHREADS}
SMissedMemoryFlow: Integer;
{$ENDIF}
{$REGION 'Util'}
type
TWinVersion = (wvUnknown, wv95, wv98, wv98SE, wvNT, wvME, wv2000, wvXP, wvVista, wv2003, wv7);
function GetWinVersion: TWinVersion;
var
osVerInfo: TOSVersionInfo;
majorVersion, minorVersion: Integer;
begin
Result := wvUnknown;
osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx(osVerInfo) then
begin
minorVersion := osVerInfo.dwMinorVersion;
majorVersion := osVerInfo.dwMajorVersion;
case osVerInfo.dwPlatformId of
VER_PLATFORM_WIN32_NT:
begin
if majorVersion <= 4 then
Result := wvNT
else if (majorVersion = 5) and (minorVersion = 0) then
Result := wv2000
else if (majorVersion = 5) and (minorVersion = 1) then
Result := wvXP
else if (majorVersion = 5) and (minorVersion = 2) then
Result := wv2003
else if (majorVersion = 6) then
Result := wvVista
else if (majorVersion = 7) then
Result := wv7;
end;
VER_PLATFORM_WIN32_WINDOWS:
begin
if (majorVersion = 4) and (minorVersion = 0) then
Result := wv95
else if (majorVersion = 4) and (minorVersion = 10) then
begin
if osVerInfo.szCSDVersion[1] = 'A' then
Result := wv98SE
else
Result := wv98;
end
else if (majorVersion = 4) and (minorVersion = 90) then
Result := wvME
else
Result := wvUnknown;
end;
end;
end;
end;
function GetMethodAddress(AStub: Pointer): Pointer;
const
CALL_OPCODE = $E8;
begin
if PBYTE(AStub)^ = CALL_OPCODE then
begin
Inc(Integer(AStub));
Result := Pointer(Integer(AStub) + SizeOf(Pointer) + PInteger(AStub)^);
end
else
Result := nil;
end;
procedure AddressPatch(const ASource, ADestination: Pointer);
const
JMP_OPCODE = $E9;
SIZE = SizeOf(TJump);
var
NewJump: PJump;
OldProtect: Cardinal;
begin
if VirtualProtect(ASource, SIZE, PAGE_EXECUTE_READWRITE, OldProtect) then
begin
NewJump := PJump(ASource);
NewJump.OpCode := JMP_OPCODE;
NewJump.Distance := Pointer(Integer(ADestination) - Integer(ASource) - 5);
FlushInstructionCache(GetCurrentProcess, ASource, SizeOf(TJump));
VirtualProtect(ASource, SIZE, OldProtect, #OldProtect);
end;
end;
function PatchCodeDWORD(ACode: PDWORD; AValue: DWORD): Boolean;
var
LRestoreProtection, LIgnore: DWORD;
begin
Result := False;
if VirtualProtect(ACode, SizeOf(ACode^), PAGE_EXECUTE_READWRITE, LRestoreProtection) then
begin
Result := True;
ACode^ := AValue;
Result := VirtualProtect(ACode, SizeOf(ACode^), LRestoreProtection, LIgnore);
if not Result then
Exit;
Result := FlushInstructionCache(GetCurrentProcess, ACode, SizeOf(ACode^));
end;
end;
{$ENDREGION}
function GetInstanceList: TList;
begin
Result := TClassVars.ListClassVars;
end;
procedure SaveInstancesToFile;
begin
TClassVars.SaveToDisk;
end;
procedure OldNewInstance;
asm
call TObject.NewInstance;
end;
procedure OldAfterConstruction;
asm
call TObject.InitInstance;
end;
{ TObjectHack }
type
TExecute = procedure of object;
procedure TObjectHack.CallOldFunction;
var
Routine: TMethod;
Execute: TExecute;
begin
Routine.Data := Pointer(Self);
Routine.Code := GetClassVars.OldVMTFreeInstance;
Execute := TExecute(Routine);
Execute;
end;
constructor TObjectHack.Create;
begin
end;
procedure TObjectHack.DecCounter;
var
ThreadId: Cardinal;
begin
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - Self.InstanceSize;
ThreadId := 0;
if (Self.ClassType.InheritsFrom(TThread)) then
ThreadId := TThread(Self).ThreadID;
{$ENDIF}
GetClassVars.BaseInstanceCount := GetClassVars.BaseInstanceCount -1;
CallOldFunction;
{$IFDEF WATCHTHREADS}
if ThreadId <> 0 then
begin
if SThreadMemory[ThreadId] < 0 then
SMissedMemoryFlow := SMissedMemoryFlow + SThreadMemory[ThreadId];
SThreadMemory[ThreadId] := 0;
end;
{$ENDIF}
end;
destructor TObjectHack.Destroy;
begin
inherited;
end;
class function TObjectHack.GetClassVars: TClassVars;
begin
Result := PClassVars(Integer(Self) + vmtAutoTable)^;
end;
function _InitializeHook(AClass: TClass; AOffset: Integer; HookAddress: Pointer): Boolean;
var
lAddress: Pointer;
lProtect: DWord;
begin
lAddress := Pointer(Integer(AClass) + AOffset);
Result := VirtualProtect(lAddress, 4, PAGE_READWRITE, #lProtect);
if not Result then
Exit;
CopyMemory(lAddress, #HookAddress, 4);
Result := VirtualProtect(lAddress, 4, lProtect, #lProtect);
end;
class procedure TObjectHack.SetClassVars(AClassVars: TClassVars);
begin
AClassVars.BaseClassName := Self.ClassName;
AClassVars.BaseInstanceSize := Self.InstanceSize;
AClassVars.OldVMTFreeInstance := PPointer(Integer(TClass(Self)) + vmtFreeInstance)^;
if Self.ClassParent <> nil then
AClassVars.BaseParentClassName := Self.ClassParent.ClassName;
PatchCodeDWORD(PDWORD(Integer(Self) + vmtAutoTable), DWORD(AClassVars));
_InitializeHook(Self, vmtFreeInstance, #TObjectHack.DecCounter);
end;
procedure RegisterClassVarsSupport(const Classes: array of TObjectHack);
var
LClass: TObjectHack;
begin
for LClass in Classes do
if LClass.GetClassVars = nil then
LClass.SetClassVars(TClassVars.Create)
else
raise Exception.CreateFmt('Class %s has automated section or duplicated registration.', [LClass.ClassName]);
end;
procedure TObjectHack.IncCounter;
begin
if GetClassVars = nil then
RegisterClassVarsSupport(Self);
GetClassVars.BaseInstanceCount := GetClassVars.BaseInstanceCount + 1;
end;
{ TClassVars }
constructor TClassVars.Create;
begin
ListClassVars.Add(Self);
end;
class procedure TClassVars.SaveToDisk;
var
LStringList: TStringList;
i: Integer;
begin
LStringList := TStringList.Create;
try
LStringList.Add('CLASS | NUMBER OF INSTANCES');
{$IFDEF TRACEINSTANCES}
for i := 0 to ListClassVars.Count -1 do
if TClassVars(ListClassVars.Items[I]).BaseInstanceCount > 0 then
LStringList.Add(TClassVars(ListClassVars.Items[I]).BaseClassName + '|' + IntToStr(TClassVars(ListClassVars.Items[I]).BaseInstanceCount));
{$ENDIF}
{$IFDEF TRACEBUFFER}
for I := 0 to SIZE_OF_MAP do
if SMap[I] > 0 then
LStringList.Add(Format('Mem. Size: %d | Amount: %d', [I, SMap[I]]));
{$ENDIF}
LStringList.SaveToFile(ExtractFilePath(ParamStr(0)) + 'MemReport.txt');
finally
FreeAndNil(LStringList);
end;
end;
//////////////////////////////////////////////////////////////////////////////////////
/// Memory manager controller
function IsInMap(AValue: Integer): Boolean; inline;
begin
try
Result := (AValue > Integer(#SMap)) and (AValue <= Integer(#SMap[SIZE_OF_MAP]));
except
Result := False;
end;
end;
function MemorySizeOfPos(APos: Integer): Integer; inline;
begin
Result := (APos - Integer(#SMap)) div SIZE_OF_INT;
end;
function NAllocMem(Size: Cardinal): Pointer;
var
pIntValue: ^Integer;
MapSize: Integer;
ThreadId: Cardinal;
begin
if Size > SIZE_OF_MAP then
MapSize := SIZE_OF_MAP
else
MapSize := Size;
Result := SDefaultAllocMem(Size + GAP_SIZE);
pIntValue := Result;
SMap[MapSize] := SMap[MapSize] + 1;
pIntValue^ := Integer(#SMap[MapSize]);
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Size;
pIntValue := Pointer(Integer(Result) + SIZE_OF_INT);
pIntValue^ := ThreadId;
{$ENDIF}
Result := Pointer(Integer(Result) + GAP_SIZE);
end;
function NGetMem(Size: Integer): Pointer;
var
LPointer: Pointer;
pIntValue: ^Integer;
MapSize: Integer;
ThreadId: Cardinal;
begin
if Size > SIZE_OF_MAP then
MapSize := SIZE_OF_MAP
else
MapSize := Size;
LPointer := SDefaultGetMem(Size + GAP_SIZE);
pIntValue := LPointer;
SMap[MapSize] := SMap[MapSize] + 1;
pIntValue^ := Integer(#SMap[MapSize]);
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Size;
pIntValue := Pointer(Integer(LPointer) + SIZE_OF_INT);
pIntValue^ := ThreadId;
{$ENDIF}
Result := Pointer(Integer(LPointer) + GAP_SIZE);
end;
function NFreeMem(P: Pointer): Integer;
var
pIntValue: ^Integer;
LPointer: Pointer;
ThreadId: Cardinal;
LFreed: Boolean;
begin
LPointer := Pointer(Integer(P) - GAP_SIZE);
pIntValue := LPointer;
if IsInMap(pIntValue^) then
begin
{$IFDEF WATCHTHREADS}
ThreadId := Integer(Pointer(Integer(pIntValue) + SIZE_OF_INT)^);
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - MemorySizeOfPos(pIntValue^);
{$ENDIF}
Integer(Pointer(pIntValue^)^) := Integer(Pointer(pIntValue^)^) - 1;
Result := SDefaultFreeMem(LPointer);
end
else
Result := SDefaultFreeMem(P);
end;
function NReallocMem(P: Pointer; Size: Integer): Pointer;
var
pIntValue: ^Integer;
LPointer: Pointer;
LSizeMap: Integer;
ThreadId: Cardinal;
begin
LPointer := Pointer(Integer(P) - GAP_SIZE);
pIntValue := LPointer;
if not IsInMap(pIntValue^) then
begin
Result := SDefaultReallocMem(P, Size);
Exit;
end;
if Size > SIZE_OF_MAP then
LSizeMap := SIZE_OF_MAP
else
LSizeMap := Size;
//Uma vez com o valor setado, não pode remover o setor
Integer(Pointer(pIntValue^)^) := Integer(Pointer(pIntValue^)^) - 1;
{$IFDEF WATCHTHREADS}
ThreadId := Integer(Pointer(Integer(pIntValue) + SIZE_OF_INT)^);
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - MemorySizeOfPos(pIntValue^) + Size;
{$ENDIF}
Result := SDefaultReallocMem(LPointer, Size + GAP_SIZE);
SMap[LSizeMap] := SMap[LSizeMap] + 1;
pIntValue := Result;
pIntValue^ := Integer(#SMap[LSizeMap]);
Result := Pointer(Integer(Result) + GAP_SIZE);
end;
procedure TObjectHack.NFreeInstance;
var
ThreadId: Cardinal;
begin
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - Self.InstanceSize;
{$ENDIF}
CleanupInstance;
SDefaultFreeMem(Self);
end;
class function TObjectHack.NNewInstance: TObject;
var
ThreadId: Cardinal;
begin
Result := InitInstance(SDefaultGetMem(Self.InstanceSize));
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Self.InstanceSize;
{$ENDIF}
end;
class function TObjectHack.NNewInstanceTrace: TObject;
var
ThreadId: Cardinal;
begin
try
Result := InitInstance(SDefaultGetMem(Self.InstanceSize));
if (Result.ClassType = TClassVars) or (Result is EExternal) then
Exit;
TObjectHack(Result).IncCounter;
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Self.InstanceSize;
{$ENDIF}
except
raise Exception.Create(Result.ClassName);
end;
end;
procedure InitializeArray;
var
I: Integer;
begin
for I := 0 to SIZE_OF_MAP do
SMap[I] := 0;
end;
type
PLocalTest = ^LocalTest;
LocalTest = record
Size: integer;
Size2: string;
end;
procedure ApplyMemoryManager;
var
LMemoryManager: TMemoryManagerEx;
begin
GetMemoryManager(LMemoryManager);
SDefaultGetMem := LMemoryManager.GetMem;
{$IFNDEF TRACEBUFFER}
Exit;
{$ENDIF}
LMemoryManager.GetMem := NGetMem;
SDefaultFreeMem := LMemoryManager.FreeMem;
LMemoryManager.FreeMem := NFreeMem;
SDefaultReallocMem := LMemoryManager.ReallocMem;
LMemoryManager.ReallocMem := NReallocMem;
SDefaultAllocMem := LMemoryManager.AllocMem;
LMemoryManager.AllocMem := NAllocMem;
SetMemoryManager(LMemoryManager);
end;
procedure TestRecord;
var
LTest: PLocalTest;
begin
LTest := AllocMem(1);
Dispose(LTest);
LTest := AllocMem(SIZE_OF_MAP + 1);
Dispose(LTest);
New(LTest);
ReallocMem(LTest, SIZE_OF_MAP +1);
Dispose(LTest);
end;
procedure TesteObject;
var
LTestObject: TObject;
begin
LTestObject := TObject.Create;
LTestObject.Free;
end;
{ TNamedBuffer }
constructor TNamedBufferList.Create;
begin
inherited Create;
Sorted := True;
end;
function GetBufferName(ASize: integer): string;
begin
Result := SNamedBufferList.GetBufferName(ASize);
end;
procedure RegisterNamedBuffer(ABufferName: string; ASize: integer);
begin
SNamedBufferList.RegisterNamedBuffer(ABufferName, ASize);
end;
function TNamedBufferList.GetBufferName(ASize: integer): string;
var
LIndex: Integer;
begin
Result := 'Unknow';
LIndex := IndexOf(ASize);
if LIndex = -1 then
Exit;
Result := TNamedBuffer(Objects[LIndex]).Names;
end;
procedure TNamedBufferList.RegisterNamedBuffer(ABufferName: string; ASize: integer);
var
LIndex: Integer;
LNamedBuffer: TNamedBuffer;
begin
LIndex := IndexOf(ASize);
if LIndex = -1 then
begin
LNamedBuffer := TNamedBuffer.Create;
LNamedBuffer.Names := 'Possible types: ' + ABufferName;
Self.AddObject(ASize, LNamedBuffer);
end
else
TNamedBuffer(Objects[LIndex]).Names := TNamedBuffer(Objects[LIndex]).Names + ' | ' + ABufferName;
end;
procedure InitializeAnalyser;
var
LCan: Boolean;
begin
SIsMemoryWatcherActive := False;
SNamedBufferList := TNamedBufferList.Create;
case GetWinVersion of
wv98, wvXP, wvVista, wv7: LCan := True;
else LCan := False;
end;
if not LCan then
Exit;
{$IFDEF TRACEINSTANCES}
TClassVars.ListClassVars := TList.Create;
{$ENDIF}
{$IFDEF TRACEBUFFER}
InitializeArray;
{$ENDIF}
ApplyMemoryManager;
/// Buffer wrapper
{$IFDEF TRACEBUFFER}
TestRecord;
{$IFNDEF TRACEINSTANCES}
AddressPatch(GetMethodAddress(#OldNewInstance), #TObjectHack.NNewInstance);
{$ENDIF}
{$ENDIF}
///Class wrapper
{$IFDEF TRACEINSTANCES}
AddressPatch(GetMethodAddress(#OldNewInstance), #TObjectHack.NNewInstanceTrace);
TesteObject;
{$ENDIF}
SIsMemoryWatcherActive := True;
end;
{ TThreadDestroy }
initialization
InitializeAnalyser
end.
I was not cleaning the parity byte on FreeMem.
I continue working on this, if someone would like to take a look or help: http://rfrezinos.wordpress.com/delphi-memory-profiler/
Att.

How to fix byte ordering issue in this piece of code?

To read a index file in a specific format, I cooked the following piece of code without considering byte ordering:
unit uCBI;
interface
uses
SysUtils,
Classes,
Generics.Collections;
type
TIndexList = class
private
FIndexList:TList<Cardinal>;
FOwnedStream:Boolean;
FMemoryStream: TMemoryStream;
function GetCount: Integer;
protected
public
constructor Create(AStream:TMemoryStream; OwnedStream:Boolean=True);
destructor Destroy; override;
function Add(const Value: Cardinal): Integer;
procedure Clear;
procedure SaveToFile(AFileName:TFileName);
procedure LoadFromFile(AFileName:TFileName);
property Count: Integer read GetCount;
end;
implementation
{ TIndexList }
function TIndexList.Add(const Value: Cardinal): Integer;
begin
Result := FIndexList.Add(Value)
end;
procedure TIndexList.Clear;
begin
FIndexList.Clear;
end;
constructor TIndexList.Create(AStream: TMemoryStream; OwnedStream: Boolean);
begin
FMemoryStream := AStream;
FOwnedStream := OwnedStream;
FIndexList := TList<Cardinal>.Create;
end;
destructor TIndexList.Destroy;
begin
if (FOwnedStream and Assigned(FMemoryStream)) then
FMemoryStream.Free;
FIndexList.Free;
//
inherited;
end;
function TIndexList.GetCount: Integer;
begin
Result := FIndexList.Count;
end;
procedure TIndexList.LoadFromFile(AFileName: TFileName);
var
lMemoryStream:TMemoryStream;
lCount:Cardinal;
begin
lMemoryStream := TMemoryStream.Create;
try
lMemoryStream.LoadFromFile(AFileName);
lMemoryStream.ReadBuffer(lCount,SizeOf(Cardinal));
if (lCount = Cardinal((lMemoryStream.Size-1) div SizeOf(Cardinal))) then
begin
FMemoryStream.Clear;
lMemoryStream.Position :=0;
FMemoryStream.CopyFrom(lMemoryStream,lMemoryStream.Size)
end else
raise Exception.CreateFmt('Corrupted CBI file: %s',[ExtractFileName(AFileName)]);
finally
lMemoryStream.Free;
end;
end;
procedure TIndexList.SaveToFile(AFileName: TFileName);
var
lCount:Cardinal;
lItem:Cardinal;
begin
FMemoryStream.Clear;
lCount := FIndexList.Count;
FMemoryStream.WriteBuffer(lCount,SizeOf(Cardinal));
for lItem in FIndexList do
begin
FMemoryStream.WriteBuffer(lItem,SizeOf(Cardinal));
end;
//
FMemoryStream.SaveToFile(AFileName);
end;
end.
It tested it and seems to work well as needed. Great was my suprise when I pursue extensive tests with real sample file. In fact the legacy format was devised with Amiga computer with a different byte ordering.
My Question:
How can I fix it ?
I want to keep the code unchanged and wonder wether a decorated TMemorySream will do so that I can transparently switch between big endian and little endian.
To change 'endianness' of Cardinals you can use the following:
function EndianChange(Value: Cardinal): Cardinal;
var
A1: array [0..3] of Byte absolute Value;
A2: array [0..3] of Byte absolute Result;
I: Integer;
begin
for I:= 0 to 3 do begin
A2[I]:= A1[3 - I];
end;
end;
If you want to keep your code unchanged, you can write your own TMemoryStream descendant and override its Read and Write methods using the above function, like that:
function TMyMemoryStream.Read(var Buffer; Count: Integer): Longint;
var
P: PCardinal;
I, N: Integer;
begin
inherited;
P:= #Buffer;
Assert(Count and 3 = 0);
N:= Count shr 2;
while N > 0 do begin
P^:= EndianChange(P^);
Inc(P);
Dec(N);
end;
end;

How Can I Save a Dynamic Array to a FileStream in Delphi?

I have the following structures in Delphi 2009:
type
IndiReportIndi = record
IndiName: string;
NameNum: integer;
ReportIndiName: string;
end;
var
XRefList: array of IndiReportIndi;
where XRefList is a dynamic array.
I want to save XRefList to a FileStream. How do I do that AND include all the IndiName and ReportIndiName strings so that they will all be retrievable again when I later load from that FileStream?
type
IndiReportIndi = record
IndiName: string;
NameNum: integer;
ReportIndiName: string;
procedure SaveToStream(Stream: TStream);
procedure LoadFromStream(Stream: TStream);
end;
type
TXRefList = array of IndiReportIndi;
function LoadString(Stream: TStream): string;
var
N: Integer;
begin
Result:= '';
Stream.ReadBuffer(N, SizeOf(Integer));
if N > 0 then begin
SetLength(Result, N);
// Stream.ReadBuffer(Result[1], N * SizeOf(Char));
// fast version - see comment by A.Bouchez
Stream.ReadBuffer(Pointer(Result)^, N * SizeOf(Char));
end;
end;
procedure SaveString(Stream: TStream; const S: string);
var
N: Integer;
begin
N:= Length(S);
Stream.WriteBuffer(N, SizeOf(Integer));
if N > 0 then
// Stream.WriteBuffer(S[1], N * SizeOf(Char));
// fast version - see comment by A.Bouchez
Stream.WriteBuffer(Pointer(S)^, N * SizeOf(Char));
end;
procedure IndiReportIndi.LoadFromStream(Stream: TStream);
var
S: string;
begin
IndiName:= LoadString(Stream);
Stream.ReadBuffer(NameNum, SizeOf(Integer));
ReportIndiName:= LoadString(Stream);
end;
procedure IndiReportIndi.SaveToStream(Stream: TStream);
begin
SaveString(Stream, IndiName);
Stream.WriteBuffer(NameNum, SizeOf(Integer));
SaveString(Stream, ReportIndiName);
end;
function LoadXRefList(Stream: TStream): TXRefList;
var
N: Integer;
I: Integer;
begin
Stream.ReadBuffer(N, SizeOf(Integer));
if N <= 0 then Result:= nil
else begin
SetLength(Result, N);
for I:= 0 to N - 1 do
Result[I].LoadFromStream(Stream);
end;
end;
procedure SaveXRefList(Stream: TStream; const List: TXRefList);
var
N: Integer;
I: Integer;
begin
N:= Length(List);
Stream.WriteBuffer(N, SizeOf(Integer));
for I:= 0 to N - 1 do
List[I].SaveToStream(Stream);
end;
Use: http://code.google.com/p/kblib/
type
IndiReportIndi = record
IndiName: string;
NameNum: integer;
ReportIndiName: string;
end;
TXRefList = array of IndiReportIndi;
var
XRefList: TXRefList;
To save whole XRefList to stream use:
TKBDynamic.WriteTo(lStream, XRefList, TypeInfo(TXRefList));
To load it back:
TKBDynamic.ReadFrom(lStream, XRefList, TypeInfo(TXRefList));
var
S: TStream;
W: TWriter;
A: array of IndiReportIndi;
E: IndiReportIndi;
...
begin
S := nil;
W := nil;
try
S := TFileStream.Create(...);
W := TWriter.Create(S);
W.WriteInteger(Length(A));
for E in A do
begin
W.WriteString(E.IndiName);
W.WriteInteger(E.NameNum);
W.WriteString(E.ReportIndiName);
end;
finally
W.Free;
S.Free
end;
end;
To read those data you use a TReader and ReadInteger/ReadString.
Simple TFileStreamEx to save variables
http://forum.chertenok.ru/viewtopic.php?t=4642
Work with them from 2005th year, without any problems...
Just for the answer to be accurate:
Consider taking a look at the TDynArray wrapper, which is able to serialize any record into binary, and also to/from dynamic arrays.
There are a lot of TList-like methods, including new methods (like hashing or binary search).
Very optimized for speed and disk use, works for Delphi 5 up to XE2 - and Open Source.
See also How to store dynamic arrays in a TList?

How to "scan" the full list of currently-installed VCL components

I still haven't found a truly satisfactory answer to this question, and am now considering rolling my own. I have ModelMaker and GExperts, and neither seems to load the comprehensive class-hierarchy I am looking for. As well, I don't think the folks at DevExpress will fork over the CDK code which compiles a full class list to inherit from... ;-)
SO...
If ALL I want to do is build a self-referencing table of all registered component classes (or even all classes including non-components, if that's just as easy/possible), what would be the best way to go about doing that?
Note: I don't really need property / method details; JUST a complete list of class names (and parent names) I can store to a table and put in a treeview. Anything beyond that, though, is more than welcome as bonus info. :-)
Update later:
One answer that shows up in my "recent" section on SO, but not here on the question (maybe they erased it?), was this:"u may want to take a look on code of Component Search, it may help you to enumrate all components installed." Is that code available? Is so, where is it hiding? Would be interesting to study.
Unfortunately, the code implementing the RegisterClass mechanism is hidden in Classes implementation section.
If you need this for getting the list of components installed in the IDE, you can write a design package, install it into the IDE and use IOTAPackageServices in ToolsAPI unit. This will give you the list of installed packages and their components.
Note: You'll have to add designide.dcp to your 'requires' clause to be able to use Delphi's internal units like ToolsAPI.
A bit more work but a more generic way would be to enumerate all loaded modules. You can call GetPackageInfo (SysUtils) on a package module to enumerate contained unit names and required packages. However this will not give you a list of classes contained in the package.
You could enumerate the package's list of exported functions (e.g. with TJclPeImage in the JCL) and search for those named like this:
#<unit_name>#<class_name>#
for example: '#System#TObject#'.
By calling GetProcAddress with the function name you get the TClass reference. From there you can walk the hierarchy using ClassParent. This way you can enumerate all classes in all packages loaded in a process running a Delphi executable compiled with runtime packages (Delphi IDE, too).
Another idea is to scan for type information which is on top of the list of exported functions so you can skip enumerating further. The type infos are exported with names starting with prefix '#$xp$'. Here's an example:
unit PackageUtils;
interface
uses
Windows, Classes, SysUtils, Contnrs, TypInfo;
type
TDelphiPackageList = class;
TDelphiPackage = class;
TDelphiProcess = class
private
FPackages: TDelphiPackageList;
function GetPackageCount: Integer;
function GetPackages(Index: Integer): TDelphiPackage;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Clear; virtual;
function FindPackage(Handle: HMODULE): TDelphiPackage;
procedure Reload; virtual;
property PackageCount: Integer read GetPackageCount;
property Packages[Index: Integer]: TDelphiPackage read GetPackages;
end;
TDelphiPackageList = class(TObjectList)
protected
function GetItem(Index: Integer): TDelphiPackage;
procedure SetItem(Index: Integer; APackage: TDelphiPackage);
public
function Add(APackage: TDelphiPackage): Integer;
function Extract(APackage: TDelphiPackage): TDelphiPackage;
function Remove(APackage: TDelphiPackage): Integer;
function IndexOf(APackage: TDelphiPackage): Integer;
procedure Insert(Index: Integer; APackage: TDelphiPackage);
function First: TDelphiPackage;
function Last: TDelphiPackage;
property Items[Index: Integer]: TDelphiPackage read GetItem write SetItem; default;
end;
TDelphiPackage = class
private
FHandle: THandle;
FInfoTable: Pointer;
FTypeInfos: TList;
procedure CheckInfoTable;
procedure CheckTypeInfos;
function GetDescription: string;
function GetFileName: string;
function GetInfoName(NameType: TNameType; Index: Integer): string;
function GetShortName: string;
function GetTypeInfoCount(Kinds: TTypeKinds): Integer;
function GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
public
constructor Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
destructor Destroy; override;
property Description: string read GetDescription;
property FileName: string read GetFileName;
property Handle: THandle read FHandle;
property ShortName: string read GetShortName;
property TypeInfoCount[Kinds: TTypeKinds]: Integer read GetTypeInfoCount;
property TypeInfos[Kinds: TTypeKinds; Index: Integer]: PTypeInfo read GetTypeInfos;
end;
implementation
uses
RTLConsts, SysConst,
PSAPI, ImageHlp;
{ Package info structures copied from SysUtils.pas }
type
PPkgName = ^TPkgName;
TPkgName = packed record
HashCode: Byte;
Name: array[0..255] of Char;
end;
PUnitName = ^TUnitName;
TUnitName = packed record
Flags : Byte;
HashCode: Byte;
Name: array[0..255] of Char;
end;
PPackageInfoHeader = ^TPackageInfoHeader;
TPackageInfoHeader = packed record
Flags: Cardinal;
RequiresCount: Integer;
{Requires: array[0..9999] of TPkgName;
ContainsCount: Integer;
Contains: array[0..9999] of TUnitName;}
end;
TEnumModulesCallback = function (Module: HMODULE; Data: Pointer = nil): Boolean;
TEnumModulesProc = function (Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
const
STypeInfoPrefix = '#$xp$';
var
EnumModules: TEnumModulesProc = nil;
function PackageInfoTable(Module: HMODULE): PPackageInfoHeader; forward;
function AddPackage(Module: HMODULE; Data: {TDelphiPackageList} Pointer): Boolean;
var
InfoTable: Pointer;
begin
Result := False;
if (Module <> HInstance) then
begin
InfoTable := PackageInfoTable(Module);
if Assigned(InfoTable) then
TDelphiPackageList(Data).Add(TDelphiPackage.Create(Module, InfoTable));
end;
end;
function GetPackageDescription(Module: HMODULE): string;
var
ResInfo: HRSRC;
ResData: HGLOBAL;
begin
Result := '';
ResInfo := FindResource(Module, 'DESCRIPTION', RT_RCDATA);
if ResInfo <> 0 then
begin
ResData := LoadResource(Module, ResInfo);
if ResData <> 0 then
try
Result := PWideChar(LockResource(ResData));
UnlockResource(ResData);
finally
FreeResource(ResData);
end;
end;
end;
function EnumModulesPS(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
var
ProcessHandle: THandle;
SizeNeeded: Cardinal;
P, ModuleHandle: PDWORD;
I: Integer;
begin
Result := False;
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, GetCurrentProcessId);
if ProcessHandle = 0 then
RaiseLastOSError;
try
SizeNeeded := 0;
EnumProcessModules(ProcessHandle, nil, 0, SizeNeeded);
if SizeNeeded = 0 then
Exit;
P := AllocMem(SizeNeeded);
try
if EnumProcessModules(ProcessHandle, P, SizeNeeded, SizeNeeded) then
begin
ModuleHandle := P;
for I := 0 to SizeNeeded div SizeOf(DWORD) - 1 do
begin
if Callback(ModuleHandle^, Data) then
Exit;
Inc(ModuleHandle);
end;
Result := True;
end;
finally
FreeMem(P);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
function EnumModulesTH(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
begin
Result := False;
// todo win9x?
end;
function PackageInfoTable(Module: HMODULE): PPackageInfoHeader;
var
ResInfo: HRSRC;
Data: THandle;
begin
Result := nil;
ResInfo := FindResource(Module, 'PACKAGEINFO', RT_RCDATA);
if ResInfo <> 0 then
begin
Data := LoadResource(Module, ResInfo);
if Data <> 0 then
try
Result := LockResource(Data);
UnlockResource(Data);
finally
FreeResource(Data);
end;
end;
end;
{ TDelphiProcess private }
function TDelphiProcess.GetPackageCount: Integer;
begin
Result := FPackages.Count;
end;
function TDelphiProcess.GetPackages(Index: Integer): TDelphiPackage;
begin
Result := FPackages[Index];
end;
{ TDelphiProcess public }
constructor TDelphiProcess.Create;
begin
inherited Create;
FPackages := TDelphiPackageList.Create;
Reload;
end;
destructor TDelphiProcess.Destroy;
begin
FPackages.Free;
inherited Destroy;
end;
procedure TDelphiProcess.Clear;
begin
FPackages.Clear;
end;
function TDelphiProcess.FindPackage(Handle: HMODULE): TDelphiPackage;
var
I: Integer;
begin
Result := nil;
for I := 0 to FPackages.Count - 1 do
if FPackages[I].Handle = Handle then
begin
Result := FPackages[I];
Break;
end;
end;
procedure TDelphiProcess.Reload;
begin
Clear;
if Assigned(EnumModules) then
EnumModules(AddPackage, FPackages);
end;
{ TDelphiPackageList protected }
function TDelphiPackageList.GetItem(Index: Integer): TDelphiPackage;
begin
Result := TDelphiPackage(inherited GetItem(Index));
end;
procedure TDelphiPackageList.SetItem(Index: Integer; APackage: TDelphiPackage);
begin
inherited SetItem(Index, APackage);
end;
{ TDelphiPackageList public }
function TDelphiPackageList.Add(APackage: TDelphiPackage): Integer;
begin
Result := inherited Add(APackage);
end;
function TDelphiPackageList.Extract(APackage: TDelphiPackage): TDelphiPackage;
begin
Result := TDelphiPackage(inherited Extract(APackage));
end;
function TDelphiPackageList.First: TDelphiPackage;
begin
Result := TDelphiPackage(inherited First);
end;
function TDelphiPackageList.IndexOf(APackage: TDelphiPackage): Integer;
begin
Result := inherited IndexOf(APackage);
end;
procedure TDelphiPackageList.Insert(Index: Integer; APackage: TDelphiPackage);
begin
inherited Insert(Index, APackage);
end;
function TDelphiPackageList.Last: TDelphiPackage;
begin
Result := TDelphiPackage(inherited Last);
end;
function TDelphiPackageList.Remove(APackage: TDelphiPackage): Integer;
begin
Result := inherited Remove(APackage);
end;
{ TDelphiPackage private }
procedure TDelphiPackage.CheckInfoTable;
begin
if not Assigned(FInfoTable) then
FInfoTable := PackageInfoTable(Handle);
if not Assigned(FInfoTable) then
raise EPackageError.CreateFmt(SCannotReadPackageInfo, [ExtractFileName(GetModuleName(Handle))]);
end;
procedure TDelphiPackage.CheckTypeInfos;
var
ExportDir: PImageExportDirectory;
Size: DWORD;
Names: PDWORD;
I: Integer;
begin
if not Assigned(FTypeInfos) then
begin
FTypeInfos := TList.Create;
try
Size := 0;
ExportDir := ImageDirectoryEntryToData(Pointer(Handle), True, IMAGE_DIRECTORY_ENTRY_EXPORT, Size);
if not Assigned(ExportDir) then
Exit;
Names := PDWORD(DWORD(Handle) + DWORD(ExportDir^.AddressOfNames));
for I := 0 to ExportDir^.NumberOfNames - 1 do
begin
if StrLIComp(PChar(DWORD(Handle) + Names^), STypeInfoPrefix, StrLen(STypeInfoPrefix)) <> 0 then
Break;
FTypeInfos.Add(GetProcAddress(Handle, PChar(DWORD(Handle) + Names^)));
Inc(Names);
end;
except
FreeAndNil(FTypeInfos);
raise;
end;
end;
end;
function TDelphiPackage.GetDescription: string;
begin
Result := GetPackageDescription(Handle);
end;
function TDelphiPackage.GetFileName: string;
begin
Result := GetModuleName(FHandle);
end;
function TDelphiPackage.GetInfoName(NameType: TNameType; Index: Integer): string;
var
P: Pointer;
Count: Integer;
I: Integer;
begin
Result := '';
CheckInfoTable;
Count := PPackageInfoHeader(FInfoTable)^.RequiresCount;
P := Pointer(Cardinal(FInfoTable) + SizeOf(TPackageInfoHeader));
case NameType of
ntContainsUnit:
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Count := Integer(P^);
P := Pointer(Cardinal(P) + SizeOf(Integer));
if (Index >= 0) and (Index < Count) then
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
Result := PUnitName(P)^.Name;
end;
end;
ntRequiresPackage:
if (Index >= 0) and (Index < Count) then
begin
for I := 0 to Index - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Result := PPkgName(P)^.Name;
end;
ntDcpBpiName:
if PPackageInfoHeader(FInfoTable)^.Flags and pfPackageModule <> 0 then
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Count := Integer(P^);
P := Pointer(Cardinal(P) + SizeOf(Integer));
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
Result := PPkgName(P)^.Name;
end;
end;
end;
function TDelphiPackage.GetShortName: string;
begin
Result := GetInfoName(ntDcpBpiName, 0);
end;
function TDelphiPackage.GetTypeInfoCount(Kinds: TTypeKinds): Integer;
var
I: Integer;
begin
CheckTypeInfos;
Result := 0;
for I := 0 to FTypeInfos.Count - 1 do
if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
Inc(Result);
end;
function TDelphiPackage.GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
var
I, J: Integer;
begin
CheckTypeInfos;
Result := nil;
J := -1;
for I := 0 to FTypeInfos.Count - 1 do
if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
begin
Inc(J);
if J = Index then
begin
Result := FTypeInfos[I];
Break;
end;
end;
end;
{ TDelphiPackage public }
constructor TDelphiPackage.Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
begin
inherited Create;
FHandle := AHandle;
FInfoTable := AInfoTable;
FTypeInfos := nil;
end;
destructor TDelphiPackage.Destroy;
begin
FTypeInfos.Free;
inherited Destroy;
end;
initialization
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
EnumModules := EnumModulesTH;
VER_PLATFORM_WIN32_NT:
EnumModules := EnumModulesPS;
else
EnumModules := nil;
end;
finalization
end.
Unit of the test design package installed in the IDE:
unit Test;
interface
uses
SysUtils, Classes,
ToolsAPI;
type
TTestWizard = class(TNotifierObject, IOTAWizard, IOTAMenuWizard)
private
{ IOTAWizard }
procedure Execute;
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
{ IOTAMenuWizard }
function GetMenuText: string;
end;
implementation
uses
TypInfo,
PackageUtils;
function AncestryStr(AClass: TClass): string;
begin
Result := '';
if not Assigned(AClass) then
Exit;
Result := AncestryStr(AClass.ClassParent);
if Result <> '' then
Result := Result + '\';
Result := Result + AClass.ClassName;
end;
procedure ShowMessage(const S: string);
begin
with BorlandIDEServices as IOTAMessageServices do
AddTitleMessage(S);
end;
{ TTestWizard }
procedure TTestWizard.Execute;
var
Process: TDelphiProcess;
I, J: Integer;
Package: TDelphiPackage;
PInfo: PTypeInfo;
PData: PTypeData;
begin
Process := TDelphiProcess.Create;
for I := 0 to Process.PackageCount - 1 do
begin
Package := Process.Packages[I];
for J := 0 to Package.TypeInfoCount[[tkClass]] - 1 do
begin
PInfo := Package.TypeInfos[[tkClass], J];
PData := GetTypeData(PInfo);
ShowMessage(Format('%s: %s.%s (%s)', [Package.ShortName, PData^.UnitName, PInfo^.Name, AncestryStr(PData^.ClassType)]));
end;
end;
end;
function TTestWizard.GetIDString: string;
begin
Result := 'TOndrej.TestWizard';
end;
function TTestWizard.GetName: string;
begin
Result := 'Test';
end;
function TTestWizard.GetState: TWizardState;
begin
Result := [wsEnabled];
end;
function TTestWizard.GetMenuText: string;
begin
Result := 'Test';
end;
var
Index: Integer = -1;
initialization
with BorlandIDEServices as IOTAWizardServices do
Index := AddWizard(TTestWizard.Create);
finalization
if Index <> -1 then
with BorlandIDEServices as IOTAWizardServices do
RemoveWizard(Index);
end.
You have to add designide to your requires clause. When you install this design package a new menu item Test should appear under Delphi's Help menu. Clicking it should display all loaded classes in the Messages window.
Have you tried Delphi's own class browser?
The browser gets loaded with shortcut CTRL-SHIFT-B. I believe you can access its options by right clicking in the browser. Here you have the option to show only the classes in your project or all known classes.
I haven't checked but I expect every descendant from TComponent, including installed components to be visible below the TComponent node. Use CTRL-F to search for a particular class.
Edit: according to this Delphi Wiki page, CTRL+SHIFT+B is only available in Delphi5. I don't have Delphi 2007 to check for this but if you can not find a class browser in your version, I'd suspect there isn't any.

Resources