"LongMonthNames" variable not recognized? - delphi

I have this code in my unit:
unit clsDate_u;
interface
type
TDate = class(TObject)
private
fDay, fMonth, fYear : integer;
public
constructor Create(sDate: string);
function MonthName: string;
function DaysPassedInYear: integer;
function LongDate: string;
function GetDay: integer;
function GetMonth: integer;
function GetYear: integer;
end;
implementation
{ TDate }
uses
SysUtils, DateUtils;
constructor TDate.Create(sDate: string);
begin
fDay := StrToInt(copy(sDate,1,2));
fMonth := StrToInt(copy(sDate,4,2));
fYear := StrToInt(copy(sDate,7,2));
if fYear <= 29 then
fYear := fYear + 2000
else
fYear := fYear + 1900;
end;
function TDate.DaysPassedInYear: integer;
var
iTotal, iCount: integer;
begin
iTotal := 0;
iCount := 1;
while iCount < fMonth do
begin
iTotal := iTotal + DaysInAMonth(fYear, iCount);
Inc(iCount);
end;
iTotal := iTotal + fDay;
result := iTotal;
end;
function TDate.GetDay: integer;
begin
result := fDay;
end;
function TDate.GetMonth: integer;
begin
result := fMonth;
end;
function TDate.GetYear: integer;
begin
result := fYear;
end;
function TDate.MonthName: string;
begin
result := LongMonthNames[fMonth];
end;
function TDate.LongDate: string;
begin
result := IntToStr(fDay) + ' ' + MonthName + ' ' + IntToStr(fYear);
end;
end.
I want to use the "LongMonthNames" variable in my function as you can see here:
function TDate.MonthName: string;
begin
result := LongMonthNames[fMonth];
end;
Delphi says it is an undeclared identifier and sees it as an error, but I did in fact add SysUtils and DateUtils in my uses clause.
Why does it not recognize "LongMonthNames"?
I am working in a seperate unit, but I doubt that has anything to do with the issue.

First, TDate is a poor name since it collides with the standard Delphi TDate type.
Second, the LongMonthNames thing you are looking for is a member of the TFormatSettings record. Consequently, to access this member, you need an instance of such a record.
For instance, if you want localized month names, you can use TFormatSettings.Create to create a format settings record for the current locale.
On the other hand, if you want non-localized (English) month names, you can use the TFormatSettings.Invariant class function.
For example,
var LMonthNames := TFormatSettings.Create.LongMonthNames;
for var LMonthName in LMonthNames do
ShowMessage(LMonthName);
gives you localized month names while
var LMonthNames := TFormatSettings.Invariant.LongMonthNames;
for var LMonthName in LMonthNames do
ShowMessage(LMonthName);
gives you non-localized month names.
(Obviously, in real code you would not recreate the format settings record every time.)

All I had to do was add "FormatSettings." before the "LongMonthNames", like this:
function TDate.MonthName: string;
begin
result := FormatSettings.LongMonthNames[fMonth];
end;

Related

Is delphi TQueue buggy? Using TQueue<Tbytes> return nil with dequeue

I don't understand why this very simple code failed? I'm on Delphi Tokyo release 2.
{$APPTYPE CONSOLE}
uses
System.SysUtils,
System.Generics.Collections;
procedure Main;
var
aQueue: TQueue<TBytes>;
aBytes: TBytes;
begin
aQueue := TQueue<TBytes>.create;
aBytes := TEncoding.UTF8.GetBytes('abcd');
aQueue.Enqueue(aBytes);
aBytes := aQueue.Dequeue;
Writeln(Length(aBytes)); // outputs 4 as expected
aBytes := TEncoding.UTF8.GetBytes('abcd');
aQueue.Enqueue(aBytes);
aBytes := aQueue.Dequeue;
Writeln(Length(aBytes)); // outputs 0
end;
begin
Main;
Readln;
end.
Is this a bug?
NOTE: The code works correctly on XE4, but fails also on Berlin.
This is indeed a bug. The code works correctly in XE7, but not XE8. In XE8 the output is 0 for both attempts.
Certainly the XE8 generic collections were very buggy and subsequent releases fixed many of the defects. Clearly not all have been fixed.
In XE8 Embarcadero attempted to address the issue of generic bloat caused by weaknesses in their compile/link model. Unfortunately, instead of tackling the problem at the root, they chose instead to address the issue in the library code for generic collections. Doing so they completely broke many of the generic collection classes, proving that their unit testing was weak. And of course, by addressing the problem this way they failed to address the issue of generic bloat for classes other than those in the generic collections. All in all, a sorry story that is seemingly still not over.
loki has just submitted a bug report: RSP-20400.
Note that this bug report is incorrect because (at least according to Stefan Glienke) the bug has been fixed in Tokyo 10.2.3. So upgrading to 10.2.3 should be the simplest way to resolve the problem.
Perhaps this bug report is more appropriate: RSP-17728.
Writing a generic queue isn't even difficult. Here's one that is known to work:
type
TQueue<T> = class
private
FItems: TArray<T>;
FCount: Integer;
FFront: Integer;
private
function Extract(Index: Integer): T; inline;
function GetBack: Integer; inline;
property Back: Integer read GetBack;
property Front: Integer read FFront;
procedure Grow;
procedure RetreatFront; inline;
public
property Count: Integer read FCount;
procedure Clear;
procedure Enqueue(const Value: T);
function Dequeue: T;
function Peek: T;
public
type
TEnumerator = record
private
FCollection: TQueue<T>;
FCount: Integer;
FCapacity: Integer;
FIndex: Integer;
FStartIndex: Integer;
public
class function New(Collection: TQueue<T>): TEnumerator; static;
function GetCurrent: T;
property Current: T read GetCurrent;
function MoveNext: Boolean;
end;
public
function GetEnumerator: TEnumerator;
end;
function GrownCapacity(OldCapacity: Integer): Integer;
var
Delta: Integer;
begin
if OldCapacity>64 then begin
Delta := OldCapacity div 4
end else if OldCapacity>8 then begin
Delta := 16
end else begin
Delta := 4;
end;
Result := OldCapacity + Delta;
end;
{ TQueue<T> }
function TQueue<T>.Extract(Index: Integer): T;
begin
Result := FItems[Index];
if IsManagedType(T) then begin
Finalize(FItems[Index]);
end;
end;
function TQueue<T>.GetBack: Integer;
begin
Result := Front + Count - 1;
if Result>high(FItems) then begin
dec(Result, Length(FItems));
end;
end;
procedure TQueue<T>.Grow;
var
Index: Integer;
Value: T;
Capacity: Integer;
NewItems: TArray<T>;
begin
Capacity := Length(FItems);
if Count=Capacity then begin
SetLength(NewItems, GrownCapacity(Capacity));
Index := 0;
for Value in Self do begin
NewItems[Index] := Value;
inc(Index);
end;
FItems := NewItems;
FFront := 0;
end;
end;
procedure TQueue<T>.RetreatFront;
begin
inc(FFront);
if FFront=Length(FItems) then begin
FFront := 0;
end;
end;
procedure TQueue<T>.Clear;
begin
FItems := nil;
FCount := 0;
end;
procedure TQueue<T>.Enqueue(const Value: T);
begin
Grow;
inc(FCount);
FItems[Back] := Value;
end;
function TQueue<T>.Dequeue: T;
var
Index: Integer;
begin
Assert(Count>0);
Result := Extract(Front);
RetreatFront;
dec(FCount);
end;
function TQueue<T>.Peek: T;
begin
Assert(Count>0);
Result := FItems[Front];
end;
function TQueue<T>.GetEnumerator: TEnumerator;
begin
Result := TEnumerator.New(Self);
end;
{ TQueue<T>.TEnumerator }
class function TQueue<T>.TEnumerator.New(Collection: TQueue<T>): TEnumerator;
begin
Result.FCollection := Collection;
Result.FCount := Collection.Count;
Result.FCapacity := Length(Collection.FItems);
Result.FIndex := -1;
Result.FStartIndex := Collection.Front;
end;
function TQueue<T>.TEnumerator.GetCurrent: T;
var
ActualIndex: Integer;
begin
ActualIndex := (FStartIndex + FIndex) mod FCapacity;
Result := FCollection.FItems[ActualIndex];
end;
function TQueue<T>.TEnumerator.MoveNext: Boolean;
begin
inc(FIndex);
Result := FIndex<FCount;
end;
To add to David's answer, the bug is in the Enqueue method. The top branch should be handling all reference counted managed types.
if IsManagedType(T) then
if (SizeOf(T) = SizeOf(Pointer)) and (GetTypeKind(T) <> tkRecord) then
FQueueHelper.InternalEnqueueMRef(Value, GetTypeKind(T))
else
FQueueHelper.InternalEnqueueManaged(Value)
else
But here we see that dynamic arrays are conspicuously missing in InternalEnqueueMref, which falls through without doing anything:
procedure TQueueHelper.InternalEnqueueMRef(const Value; Kind: TTypeKind);
begin
case Kind of
TTypeKind.tkUString: InternalEnqueueString(Value);
TTypeKind.tkInterface: InternalEnqueueInterface(Value);
{$IF not Defined(NEXTGEN)}
TTypeKind.tkLString: InternalEnqueueAnsiString(Value);
TTypeKind.tkWString: InternalEnqueueWideString(Value);
{$ENDIF}
{$IF Defined(AUTOREFCOUNT)}
TTypeKind.tkClass: InternalEnqueueObject(Value);
{$ENDIF}
end;
end;
It's so egregious, in fact, that the compiler actually produces no code for Enqueue when compiled (other than preamble) since the futility of the exercise can be determined from the types at compile time.
Project1.dpr.15: aQueue.Enqueue(aBytes);
0043E19E 8B45F8 mov eax,[ebp-$08]
0043E1A1 8945F4 mov [ebp-$0c],eax
0043E1A4 8B45FC mov eax,[ebp-$04]
0043E1A7 83C008 add eax,$08
0043E1AA 8945F0 mov [ebp-$10],eax
Project1.dpr.16: aBytes := aQueue.Dequeue;
0043E1AD 8D45EC lea eax,[ebp-$14]
This bug, therefore, would be expected to affect TQueue<T> for T being any type of dynamic array.

Delphi: How to get the address of a static record

type
TMyRecord = record
private
class constructor create;
public
class var MyField1: string;
class var MyField2: integer;
class var MyField3: extended;
class function ToString: string; static;
end;
class constructor TMyRecord.Create;
begin
TMyRecord.MyField1 := 'Hello, world!';
TMyRecord.MyField2 := 123;
TMyRecord.MyField3 := 3.1415927;
end;
class function TMyRecord.ToString: string;
var
RecType: TRTTIType;
RecFields: TArray<TRttiField>;
I: integer;
begin
RecType := TRTTIContext.Create.GetType(TypeInfo(TMyRecord));
Result := RecType.ToString;
RecFields := RecType.GetFields;
for I := 0 to High(RecFields) do
Result := Result + Format('%s: %s = %s', [RecFields[I].Name, RecFields[I].FieldType.ToString, RecFields[I].GetValue(#TMyRecord).ToString]) + sLineBreak;
end;
I am trying to get TMyRecord.ToString to return:
TMyRecord
MyField1: string = Hello, world!
MyField2: integer = 123;
MyField3: extended = 3.1415927;
However, I get a compiler error on GetValue(#TMyRecord) - E2029 '(' expected but ')' found
Normally GetValue should be called with the address of the 'instance' of the record. But in this case the record is static.
I do not want to convert this record to a normal record, create an instance etc. I'm trying to solve this for a static record.
How can I get the address that should be passed to GetValue?
To the best of my knowledge, class fields are not accessible through RTTI.
As said in another answer, it is not possible to get access to class var fields with RTTI.
But with a small adjustment it is still possible to get the wanted solution:
program TestClassVar;
{$APPTYPE CONSOLE}
uses
System.SysUtils,System.RTTI;
type
TMyRecord = record
type
TIR = record
MyField1: string;
MyField2: integer;
MyField3: extended;
end;
private
class constructor create;
public
class var r: TIR;
class function ToString: string; static;
end;
class constructor TMyRecord.Create;
begin
TMyRecord.r.MyField1 := 'Hello, world!';
TMyRecord.r.MyField2 := 123;
TMyRecord.r.MyField3 := 3.1415927;
end;
class function TMyRecord.ToString: string;
var
RecType: TRTTIType;
RecFields: TArray<TRttiField>;
I: integer;
firstFieldAdr: Pointer;
begin
RecType := TRTTIContext.Create.GetType(TypeInfo(TMyRecord));
Result := RecType.ToString + sLineBreak;
RecType := TRTTIContext.Create.GetType(TypeInfo(TIR));
RecFields := RecType.GetFields;
firstFieldAdr := Addr(TMyRecord.r);
for I := 0 to High(RecFields) do
Result :=
Result +
Format('%s: %s = %s',
[RecFields[I].Name,
RecFields[I].FieldType.ToString,
RecFields[I].GetValue(firstFieldAdr).ToString])
+
sLineBreak;
end;
begin
WriteLn(TMyRecord.ToString);
ReadLn;
end.
The fields are put into an inner record and the address of the first field is resolved via the Addr() function.
The drawback is that the access to the fields will have an extra r. specifier.
Actual output:
TMyRecord
MyField1: string = Hello, world!
MyField2: Integer = 123
MyField3: Extended = 3.1415927
Thank you LU RD for your contribution! Quite clever, using a nested record and declaring a local class var 'r', allowing access to both the type as well as an instance.
In the mean time I had come up with another solution, although that uses a class (with an external instance) instead of a record, which I didn't want to do, but I didn't see another way, so thanks for your solution!
type
TMyRecord = class
private
constructor create;
public
MyField1: string;
MyField2: integer;
MyField3: extended;
function ToString: string;
end;
var
MyRecord: TMyRecord;
constructor TMyRecord.Create;
begin
MyField1 := 'Hello, world!';
MyField2 := 123;
MyField3 := 3.1415927;
end;
function TMyRecord.ToString: string;
var
Field: TRttiField;
begin
Result := sLineBreak;
for Field in TRTTIContext.Create.GetType(Self.ClassType).GetFields do
Result := Result + Format('%s: %s = %s', [Field.Name, Field.FieldType.ToString, Field.GetValue(Self).ToString]) + sLineBreak;
end;

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.

Determine if string not contain number

I need a little help with a function. What I need to do is determine, if a string contains a number or not. If yes, I need only a number from the string, if not I need a whole word from it.
For example:
If my string is 'xyz 60', I need '60' from it, but if the string is 'xyz', I need the whole string:
function TForm1.FindNumberInString(InString: string): TNumberInString;
var
i, j: Integer;
ST: String;
begin
Result.TNumber := '';
Result.TIsNumber := False;
for i := 1 to Length(InString) do
begin
if (InString[i] in ['0'..'9']) then
begin
Result.TNumber := Result.TNumber + InString[i];
Result.TIsNumber := True;
end else
Result.TNumber := InString;
end;
end;
// TNumberInString is a packed record
TNumberInString = Packed Record
TNumber: string;
TIsNumber: boolean;
end;
Anyone can help what will be the problem? The Result is always 'xyz60', not '60'. I tried "if not (InString[i] in...), but it did not work, too.
Try something more like this instead:
function TForm1.FindNumberInString(InString: string): TNumberInString;
var
i, j: Integer;
begin
Result.TNumber := InString;
Result.TIsNumber := False;
for i := 1 to Length(InString) do
begin
if InString[i] in ['0'..'9'] then
begin
Result.TNumber := InString[i];
Result.TIsNumber := True;
For j := i+1 to Length(InString) do
begin
if not (InString[i] in ['0'..'9']) then
Break;
Result.TNumber := Result.TNumber + InString[j];
end;
Exit;
end;
end;
end;
I would use a Regular Expressions, and extend your record with a constructor
uses
RegularExpressions;
{$R *.dfm}
type
TNumberInString = Packed Record
TNumber: string;
TIsNumber: Boolean;
constructor Create(const Value: String);
end;
{ TNumberInString }
constructor TNumberInString.Create(const Value: String);
var
Match: TMatch;
begin
Match := TRegEx.Create('\d+').Match(Value);
TIsNumber := Match.Success;
if TIsNumber then
TNumber := Match.Value
else
TNumber := Value;
end;
Then only thing left is to call it:
procedure TForm30.FormCreate(Sender: TObject);
begin
Memo1.Lines.Clear;
Memo1.Lines.Add(TNumberInString.Create('XYZ').TNumber);
Memo1.Lines.Add(TNumberInString.Create('XYZ60').TNumber);
Memo1.Lines.Add(TNumberInString.Create('XYZ 60').TNumber);
end;
And show the result:

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