I am in front of following problem:
My Main programming Language is C++ with the Qt4 Library, but now I have to write a Pascal Wrapper, which should give the possibility to use the functions of a C DLL in Pascal.
Now I want to make it possible to invoke a method from any Pointer. But I can't find a Pascal method to invoke a method. I want something like the QMetaObject::invokeMethod method in QT. I got following code:
unit CgPConnect;
//{$mode objfpc}{$H+}
{$mode delphi}
interface
uses
Classes, SysUtils, dynlibs;
type
Callback = Record
var callbackObject: Pointer;
var objectFunction: string;
end;
CallbackObject = Record
var objectName: string;
var callback: Callback;
end;
MutableObject = Object
var name: string;
var state: string;
var properties: array of VariantMap;
var annotations: array of VariantMap;
end;
PConnect = Class
constructor create(connectorPath: string);
destructor destroy;
private
var hostactionCallbacks: array of CallbackObject;
var mConnectorPath: string;
var mConnectorLibrary: TLibHandle;
function loadConnectorLibrary: Boolean;
public
procedure registerCallbackForHostaction(objectName, objectFunction: string; callbackObject: pointer);
procedure callHostactionCallback(receivedObject :MutableObject);
var mLibraryLoaded: Boolean;
end;
implementation
constructor PConnect.create(connectorPath: string);
begin
mConnectorPath:= connectorPath;
mLibraryLoaded:= false;
//Eventuell noch slash hinzufügen
mLibraryLoaded:= loadConnectorLibrary;
end;
destructor PConnect.destroy;
begin
UnloadLibrary(mConnectorLibrary);
end;
procedure PConnect.registerCallbackForHostaction(objectName, objectFunction: string; callbackObject: pointer);
var c: Callback;
var callbackCount: integer;
begin
if mLibraryLoaded = true then
begin
c.callbackObject:= callbackObject;
c.objectFunction:= objectFunction;
callbackCount:= Length(hostactionCallbacks)+1;
SetLength(hostactionCallbacks, callbackCount);
hostactionCallbacks[callbackCount].objectName:= objectName;
hostactionCallbacks[callbackCount].callback:= c;
end;
end;
procedure PConnect.callHostactionCallback(receivedObject :MutableObject);
var receivedObjectName, objectFunction: string;
var i, count: integer;
var callbackObject: pointer;
begin
if mLibraryLoaded = true then
begin
receivedObjectName:= receivedObject.name;
count:= Length(hostactionCallbacks);
for i:=0 to count do
begin
if hostactionCallbacks[i].objectName = receivedObjectName
begin
objectFunction:= hostactionCallbacks[i].callback.objectFunction;
callbackObject:= hostactionCallbacks[i].callback.callbackObject;
if callbackObject <> 0 then
//INVOKE METHOD (objectFunction) OF OBJECT (callbackObject)
end;
end;
end;
end;
end.
I would be happy about a fast answer :)
You cannot directly and portably call a C++ method from Pascal. If your callbackfunction is a C++ object, forget it.
Otherwise fill a TMethod object and cast that to the proper "procedure of object" declaration. Don't forget the calling convention.
For more bizarre solutions you might want to have a look at (RemObjects') Pascalscript.
P.s. this is the same that you can't even call a C++ method reliably from another C++ compiler. It is not Pascal vs C++ per se.
Related
So, once again I am learning new things and I came across Smart Pointers. I had code
procedure TForm3.BitBtn1Click(Sender: TObject);
var
_StringList: ISmartPointer<TStringList>;
begin
_StringList := TSmartPointer<TStringList>.Create(TStringList.Create);
end;
As you see variable declaration is kinda odd, and simplification is needed. I came across another solution
procedure TForm3.btnDelphiClick(Sender: TObject);
var
_StringList: TStringList;
begin
_StringList := SmartGuard.SmartGuard<TStringList>(TStringList.Create(False));
end;
Sadly, it does not work with parameterless constructor
procedure TForm3.btnDelphiClick(Sender: TObject);
var
_StringList: TStringList;
begin
_StringList := SmartGuard.SmartGuard<TStringList>(TStringList.Create);
end;
[dcc32 Error] Main.pas(47): E2089 Invalid typecast
Am I out of luck here?
P.S. I know some of you would argue I should stick to try..finally block, but this is out of curiosity.
unit SmartGuard;
interface
type
IGuard = interface
['{CE522D5D-41DE-4C6F-BC84-912C2AEF66B3}']
end;
TGuard = class(TInterfacedObject, IGuard)
private
FObject: TObject;
public
constructor Create(AObject: TObject);
destructor Destroy; override;
end;
SmartGuard<T: class> = record
private
FGuard: IGuard;
FGuardedObject: T;
public
class operator Implicit(GuardedObject: T): SmartGuard<T>;
class operator Implicit(Guard: SmartGuard<T>): T;
end;
implementation
uses
{Delphi}
System.SysUtils
{Project}
;
constructor TGuard.Create(AObject: TObject);
begin
FObject := AObject;
end;
destructor TGuard.Destroy;
begin
FObject.Free;
inherited;
end;
{ SmartGuard }
class operator SmartGuard<T>.Implicit(GuardedObject: T): SmartGuard<T>;
begin
Result.FGuard := TGuard.Create(GuardedObject);
Result.FGuardedObject := GuardedObject;
end;
class operator SmartGuard<T>.Implicit(Guard: SmartGuard<T>): T;
begin
Result := Guard.FGuardedObject;
end;
end.
I would love to find a solution that would not require additional "method" calling as in here https://github.com/marcocantu/DelphiSessions/blob/master/DelphiLanguageCodeRage2018/02_SmartPointers/SmartPointerClass.pas e.g. _StringList.Value.Add('foo'); and "special" brackets e.g. _StringList := TSmartPointer<TStringList>.Create(TStringList.Create)();
The compiler needs help disambiguating
TStringList.Create
The compiler doesn't know whether this is a reference to a method, or a call to the method.
Disambiguate by adding parens to indicate that it is a call.
_StringList := SmartGuard.SmartGuard<TStringList>(TStringList.Create());
Problem solved, refer to my answer, however cannot accept it right now because stack overflow's 2 day rule. Thanks for the input everbody!
edit: The answer is removed, the answer is to remove line:
function registerWindowMessage( lpString : PChar ) : integer; stdcall; external user32 name 'RegisterWindowMessageA';
From the project because it is already defined in delphi windows api files, that's it. No need to redefine it and also the redefine does not match the newer version.
I try to revive/migrate some older Delphi 5 Enterprise (32bit) projects to a new/modern Delphi version (Delphi 10.2, 32bit) however the old versions compiles and run fine on any OS. Overall, pretty compatible.
Now I am running into this strange problem, the Delphi 10.2 form does not like to handle SHELLHOOK messages, the older compiled Delphi 5 version does. Because I don't have the source of Delphi 10.2 (free edition) forms.pas I can't see what is actually going on (different) and can't figure out why it doesn't work. Unable to debug it.
The hook registration seems to be fine, the writeln's in the FormCreate shows the following values (in extra console window):
However the overrided WndProc procedure does not handle any shellhook messages. I made a demo so you can try it yourself by creating a new project, double click on the form's onCreate and onDestroy event and replace the forms code with this:
unit main;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs;
const
// Constant for shell hook events
HSHELL_WINDOWCREATED = 1;
HSHELL_WINDOWDESTROYED = 2;
HSHELL_ACTIVATESHELLWINDOW = 3;
HSHELL_WINDOWACTIVATED = 4;
HSHELL_GETMINRECT = 5;
HSHELL_REDRAW = 6;
HSHELL_TASKMAN = 7;
HSHELL_LANGUAGE = 8;
HSHELL_ACCESSIBILITYSTATE = 11;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
FHookMsg : integer;
procedure WMShellHook(var Msg: TMessage );
protected
procedure WndProc(var Msg : TMessage); override;
public
{ Public declarations }
end;
var
Form1: TForm1;
// Not implemented Windows API functions, available at WinXP and later
function registerWindowMessage( lpString : PChar ) : integer; stdcall; external user32 name 'RegisterWindowMessageA';
function registerShellHookWindow( hWnd : THandle ) : bool; stdcall; external user32 name 'RegisterShellHookWindow';
function deregisterShellHookWindow( hWnd : THandle ) : bool; stdcall; external user32 name 'DeregisterShellHookWindow';
implementation
{$R *.dfm}
procedure TForm1.FormActivate(Sender: TObject);
begin
// send a message
sendMessage( handle, WM_USER+$40, 1, 2 );
postMessage( handle, WM_USER+$40, 3, 4 );
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
writeln( handle );
FHookMsg:=registerWindowMessage('SHELLHOOK'+#0 );
writeln( FHookMsg );
writeln( registerShellHookWindow( handle ) );
writeln( handle ); // handle still the same
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
deregisterShellHookWindow( handle );
writeln( handle ); // set breakpoint here, handle still the same
end;
procedure TForm1.FormShow(Sender: TObject);
begin
writeln( handle ); // handle still the same
end;
procedure TForm1.WndProc(var Msg : TMessage);
begin
// writeln( handle ); even when i showed this, handle is still the same
if( Msg.Msg = WM_USER+$40 ) then
begin
writeln( 'wParam is: ', Msg.wParam );
writeln( 'lParam is: ', Msg.lParam );
exit;
end;
if( Msg.Msg = FHookMsg ) then
begin
// Not executed in Delphi 10.2 generated exe
writeln( 'wParam is: ', Msg.wParam );
WMShellHook( Msg );
exit;
end;
inherited; // call this for default behaviour
end;
procedure TForm1.WMShellHook( var Msg: TMessage );
begin
// Simple however effective way to detect window changes at low costs.
if( Msg.wparam = HSHELL_WINDOWCREATED )
or ( Msg.wparam = HSHELL_WINDOWDESTROYED )
or ( Msg.wparam = HSHELL_WINDOWACTIVATED ) then
begin
// Not executed in Delphi 10.2 generated exe
writeln('here' );
end;
end;
end.
PS: Don't forget to switch linker option "generate console application" on to avoid writeln errors while running this demo.
Can somebody tell what's going on and why it doesn't work?
EDIT:
Example with allocateHwnd and deallocateHwnd, does not receive anything. Why not? Followed this example.
unit unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs;
const
// Constant for shell hook events
HSHELL_WINDOWCREATED = 1;
HSHELL_WINDOWDESTROYED = 2;
HSHELL_ACTIVATESHELLWINDOW = 3;
HSHELL_WINDOWACTIVATED = 4;
HSHELL_GETMINRECT = 5;
HSHELL_REDRAW = 6;
HSHELL_TASKMAN = 7;
HSHELL_LANGUAGE = 8;
HSHELL_ACCESSIBILITYSTATE = 11;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FHookWndHandle : THandle;
FHookMsg : integer;
procedure WMShellHook(var Msg: TMessage );
protected
procedure WndMethod(var Msg: TMessage);
public
{ Public declarations }
end;
var
Form1: TForm1;
// Not implemented Windows API functions, available at WinXP and later
function registerWindowMessage( lpString : PChar ) : integer; stdcall; external user32 name 'RegisterWindowMessageA';
function registerShellHookWindow( hWnd : THandle ) : bool; stdcall; external user32 name 'RegisterShellHookWindow';
function deregisterShellHookWindow( hWnd : THandle ) : bool; stdcall; external user32 name 'DeregisterShellHookWindow';
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FHookWndHandle:=allocateHWnd(WndMethod);
FHookMsg:=registerWindowMessage('SHELLHOOK'+#0 );
writeln( FHookMsg );
writeln( registerShellHookWindow( FHookWndHandle ) );
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
deregisterShellHookWindow( FHookWndHandle );
deallocateHWnd( FHookWndHandle );
end;
procedure TForm1.WndMethod(var Msg: TMessage);
begin
if( Msg.Msg = FHookMsg ) then
begin
// Not executed in Delphi 10.2 generated exe
writeln( 'wParam is: ', Msg.wParam );
WMShellHook( Msg );
exit;
end;
end;
procedure TForm1.WMShellHook( var Msg: TMessage );
begin
// Simple however effective way to detect window changes at low costs.
if( Msg.wparam = HSHELL_WINDOWCREATED )
or ( Msg.wparam = HSHELL_WINDOWDESTROYED )
or ( Msg.wparam = HSHELL_WINDOWACTIVATED ) then
begin
// Not executed in Delphi 10.2 generated exe
writeln('here' );
end;
end;
end.
function registerWindowMessage( lpString : PChar ) : integer; stdcall;
external user32 name 'RegisterWindowMessageA';
This declaration is correct in ANSI versions of Delphi but incorrect in Unicode Delphi. In Unicode Delphi you should be using the W version of the function. As it stands your version sends UTF16 text to a function that expects ANSI and that mismatch means the wrong message name will be received by the function. Correct it like this:
function registerWindowMessage( lpString : PChar ) : integer; stdcall;
external user32 name 'RegisterWindowMessageW';
That's probably the most important problem. Because of this text encoding mismatch you will be registering a window message with the wrong name and so won't receive the messages you expect.
Note also that the return type should be UINT. You should change this, and the type of FHookMsg, although doing so won't actually change any behaviour.
VCL windowed controls are subject to window recreation. There are plenty of reasons that it might happen, but the window handle behind the form can be destroyed and recreated at any point in the lifetime of the form.
Your code has always been wrong but you appear to have got away with it. There are two solutions:
Register and unregister the hook in overridden CreateWnd or DestroyWnd.
Use a non VCL window to handle the hook. Use AllocateHWnd and DeallocateHWnd.
Personally I regard the second option to be preferable.
Those are the mistakes that can I can see in the code provided. There are other possible problems. You describe this as happening inside a console application but of course we cannot see how you create the form, how you run the message loop and so on. So I guess there could well be other mistakes in the code that we cannot see.
Change your declaration of RegisterWindowMessage to this:
function RegisterWindowMessage( lpString : PChar ) : integer; stdcall; external user32 name 'RegisterWindowMessageW';
I am trying to add NSStatusItem in a Delphi application for OSX. Searched for sample code to help me with that but got stuck when defining an interface:
Here is the code:
// Source: https://forums.embarcadero.com/thread.jspa?threadID=108449
unit Unit2;
interface
uses Macapi.ObjectiveC, Macapi.CocoaTypes, Macapi.Foundation, Macapi.AppKit,
Macapi.Helpers, Macapi.ObjcRuntime, System.TypInfo, FMX.Platform, FMX.Platform.Mac;
type
TFMXTrayItem = class(TOCLocal)
private
NSStatItem : NSStatusItem;
public
constructor Create;
destructor Destroy; override;
function GetObjectiveCClass: PTypeInfo; override;
procedure call_mymethod; cdecl;
end;
implementation
constructor TFMXTrayItem.Create;
var
NSContMenu : NSMenu;
NSContItem : NSMenuItem;
NSStatBar : NSStatusBar;
NSImg : NSImage;
AppBundle : NSBundle;
NSpImg: Pointer;
Path: String;
begin
inherited Create;
NSStatBar := TNSStatusBar.Create;
NSStatBar := TNSStatusBar.Wrap(TNSStatusBar.OCClass.systemStatusBar);
NSStatItem:= NSStatBar.statusItemWithLength(NSVariableStatusItemLength);
NSStatItem.setTarget(GetObjectID);
// Create context menu
NSContMenu := TNSMenu.Create;
NSContMenu := TNSMenu.Wrap(NSContMenu.initWithTitle(StrToNSStr('The caption')));
NSContItem:=TNSMenuItem.Create;
NSContItem:=TNSMenuItem.Wrap(NSContItem.initWithTitle(StrToNSStr('1. menuitem'),sel_getUid(PAnsiChar('call_mymethod')),StrToNSStr('')));
NSContItem.setTarget(GetObjectID);
NSContMenu.addItem(NSContItem);
NSContItem.release;
// Add menu
NSStatItem.retain;
NSStatItem.setHighlightMode(true);
NSStatItem.setMenu(NSContMenu);
NSContMenu.release;
// Get path to dir
AppBundle := TNSBundle.Wrap(TNSBundle.OCClass.mainBundle);
Path:=AppBundle.bundlePath.UTF8String+'/Contents/yourimage16x16.png';
NSpImg := TNSImage.Alloc.initWithContentsOfFile(StrToNSStr(Path));
// Create Icon
NSImg := TNSImage.Create;
NSImg := TNSImage.Wrap(NSpImg);
NSStatItem.setImage(NSImg);
NSImg.release;
end;
destructor TFMXTrayItem.Destroy;
begin
NSStatItem.release;
inherited;
end;
function TFMXTrayItem.GetObjectiveCClass: PTypeInfo;
begin
Result :=TypeInfo(IFMXTrayItem);
end;
procedure TFMXTrayItem.call_properties;
begin
// your event code of the menu item
end;
end.
Does anyone have any idea on how to declare the IFMXTrayItem interface?
Got it to work like this:
type
IFMXTrayItem = interface(NSObject)
['{7d2e4b38-61d9-4cf4-b78b-5f7c4188e9c0}']
procedure call_mymethod; cdecl;
end;
later edit:
Added a GUID to the interface after reading this:
This GUID is used by the compiler to identify uniquely this interface.
Strictly speaking, you can use an interface without the GUID, but you
can’t get very far using them as much of the RTL and most frameworks
that take advantage of interfaces will require that they have a GUID.
So that is a random GUID I generated but if you use this in your code you should generate your own GUID.
can anybody tell me how to make a TTrackBar object read only in C++Builder (or Delphi) XE7 in an OSX firemonkey application?
I tried the "Locked" property but it seems not working.
Cheers
dodo
Set the Enabled property to False. Locked locks the position of the trackbar in the designer so that you cannot accidentally move it.
Here's another answer because of your additional requirements. There is no "readonly" property that will keep the TrackBar enabled.
You could just use the TrackBar.OnChange event and just reset the value if the user tries to change it:
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
TrackBar1.Value := 50;
end;
A more advanced approach is using an observer in order to get a true readonly TrackBar.
TReadOnlyTrackObserver = class(TInterfacedObject, IEditLinkObserver, IObserver, ISingleCastObserver)
public
procedure Removed;
function GetActive: Boolean;
procedure SetActive(Value: Boolean);
function GetOnObserverToggle: TObserverToggleEvent;
procedure SetOnObserverToggle(AEvent: TObserverToggleEvent);
procedure Update;
function Edit: Boolean;
procedure Reset;
procedure Modified;
function IsModified: Boolean;
function IsValidChar(AKey: Char): Boolean;
function IsRequired: Boolean;
function GetIsReadOnly: Boolean;
procedure SetIsReadOnly(Value: Boolean);
property IsReadOnly: Boolean read GetIsReadOnly write SetIsReadOnly;
function GetIsEditing: Boolean;
property IsEditing: Boolean read GetIsEditing;
procedure BeginUpdate;
procedure EndUpdate;
function GetUpdating: Boolean;
property Updating: Boolean read GetUpdating;
end;
function TReadOnlyTrackObserver.GetActive: Boolean;
begin
Result := True;
end;
function TReadOnlyTrackObserver.GetIsReadOnly: Boolean;
begin
Result := True;
end;
// todo: implement the other required functions of TReadOnlyTrackObserver
var
MyObserver: IEditLinkObserver;
MyObserver := TReadOnlyTrackObserver.Create;
TrackBar1.Observers.AddObserver(TObserverMapping.EditLinkID, MyObserver);
I am hunting a bug which might be connected to unit initialization order. Is there a way to see which initialization section was executed when? I need to know the order. This is during debugging, so I have the full power of the Delphi IDE, in my case Delphi 2009.
I could set breakpoints, but this is rather tedious when having many units.
Do you have any suggestions?
Here is some code I just tested in D2010, note that you need to set a Breakpoint in System.InitUnits and get the address of InitContext var (#InitContext). Then modify CtxPtr to have this address WHILE STILL RUNNING. (Maybe someone knows a smarter way for this).
procedure TForm3.Button2Click(Sender: TObject);
var
sl: TStringList;
ps: PShortString;
CtxPtr: PInitContext;
begin
// Get the address by setting a BP in SysUtils.InitUnits (or map file?)
CtxPtr := PInitContext($4C3AE8);
sl := TStringList.Create;
try
ps := CtxPtr^.Module^.TypeInfo^.UnitNames;
for i := 0 to CtxPtr^.Module^.TypeInfo^.UnitCount - 1 do
begin
sl.Add(ps^);
// Move to next unit
DWORD(ps) := DWORD(ps) + Length(ps^) + 1;
end;
Memo1.Lines.Assign(sl);
finally
sl.Free;
end;
end;
/EDIT: and here is a version using JclDebug and a mapfile:
type
TForm3 = class(TForm)
...
private
{ Private declarations }
var
Segments: array of DWORD;
procedure PublicsByValue(Sender: TObject; const Address: TJclMapAddress; const Name: string);
procedure MapSegment(Sender: TObject; const Address: TJclMapAddress; Len: Integer; const GroupName, UnitName: string);
procedure MapClassTable(Sender: TObject; const Address: TJclMapAddress; Len: Integer; const SectionName, GroupName: string);
public
{ Public declarations }
end;
var
Form3: TForm3;
CtxPtr: PInitContext = nil; // Global var
procedure TForm3.MapClassTable(Sender: TObject; const Address: TJclMapAddress;
Len: Integer; const SectionName, GroupName: string);
begin
SetLength(Segments, Length(Segments) + 1);
SegMents[Address.Segment-1] := Address.Offset;
end;
procedure TForm3.PublicsByValue(Sender: TObject; const Address: TJclMapAddress;
const Name: string);
const
InitContextStr = 'System.InitContext';
begin
if RightStr(Name, Length(InitContextStr)) = InitContextStr then
begin
CtxPtr := PInitContext(Segments[Address.Segment-1] + Address.Offset);
end;
end;
procedure TForm3.Button2Click(Sender: TObject);
var
MapParser: TJclMapParser;
MapFile: String;
sl: TStringList;
ps: PShortString;
i: Integer;
begin
MapFile := ChangeFileExt(Application.ExeName, '.map');
MapParser := TJclMapParser.Create(MapFile);
try
MapParser.OnPublicsByValue := PublicsByValue;
MapParser.OnClassTable := MapClassTable;
MapParser.Parse;
finally
MapParser.Free;
end;
if CtxPtr = nil then
Exit;
sl := TStringList.Create;
try
ps := CtxPtr^.Module^.TypeInfo^.UnitNames;
for i := 0 to CtxPtr^.Module^.TypeInfo^.UnitCount - 1 do
begin
sl.Add(ps^);
// Move to next unit
DWORD(ps) := DWORD(ps) + Length(ps^) + 1;
end;
Memo1.Lines.Assign(sl);
finally
sl.Free;
end;
end;
Output in my case:
Variants
VarUtils
Windows
Types
SysInit
System
SysConst
SysUtils
Character
RTLConsts
Math
StrUtils
ImageHlp
MainUnit
JwaWinNetWk
JwaWinType
JwaWinNT
JwaWinDLLNames
JwaWinError
StdCtrls
Dwmapi
UxTheme
SyncObjs
Classes
ActiveX
Messages
TypInfo
TimeSpan
CommCtrl
Themes
Controls
Forms
StdActns
ComCtrls
CommDlg
ShlObj
StructuredQueryCondition
PropSys
ObjectArray
UrlMon
WinInet
RegStr
ShellAPI
ComStrs
Consts
Printers
Graphics
Registry
IniFiles
IOUtils
Masks
DateUtils
Wincodec
WinSpool
ActnList
Menus
ImgList
Contnrs
GraphUtil
ZLib
ListActns
ExtCtrls
Dialogs
HelpIntfs
MultiMon
Dlgs
WideStrUtils
ToolWin
RichEdit
Clipbrd
FlatSB
Imm
TpcShrd
/EDIT2: And here a version for D2009 (requires JclDebug):
unit MainUnit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StrUtils, JclDebug, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
var
Segments: array of DWORD;
procedure PublicsByValue(Sender: TObject; const Address: TJclMapAddress; const Name: string);
procedure MapClassTable(Sender: TObject; const Address: TJclMapAddress; Len: Integer; const SectionName, GroupName: string);
public
{ Public declarations }
end;
var
Form1: TForm1;
CtxPtr: PInitContext = nil; // Global var
Symbols: TStringList;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
MapParser: TJclMapParser;
MapFile: String;
sl: TStringList;
ps: PShortString;
i: Integer;
s: String;
Idx: Integer;
begin
MapFile := ChangeFileExt(Application.ExeName, '.map');
MapParser := TJclMapParser.Create(MapFile);
try
MapParser.OnPublicsByValue := PublicsByValue;
MapParser.OnClassTable := MapClassTable;
Memo1.Lines.BeginUpdate;
MapParser.Parse;
Memo1.Lines.EndUpdate;
finally
MapParser.Free;
end;
if CtxPtr = nil then
Exit;
sl := TStringList.Create;
try
for i := 0 to CtxPtr^.InitTable.UnitCount-1 do
begin
if Assigned(CtxPtr^.InitTable.UnitInfo^[i].Init) then
begin
s := Format('$%.8x', [DWORD(CtxPtr^.InitTable.UnitInfo^[i].Init)]);
Idx := Symbols.IndexOfObject(TObject(CtxPtr^.InitTable.UnitInfo^[i].Init));
if Idx > -1 then
begin
Memo1.Lines.Add(Format('%.4d: %s', [i, Symbols[Idx]]));
end;
end;
end;
finally
sl.Free;
end;
end;
procedure TForm1.MapClassTable(Sender: TObject; const Address: TJclMapAddress;
Len: Integer; const SectionName, GroupName: string);
begin
SetLength(Segments, Length(Segments) + 1);
SegMents[Address.Segment-1] := Address.Offset;
end;
procedure TForm1.PublicsByValue(Sender: TObject; const Address: TJclMapAddress;
const Name: string);
const
InitContextStr = 'System.InitContext';
begin
if RightStr(Name, Length(InitContextStr)) = InitContextStr then
begin
CtxPtr := PInitContext(Segments[Address.Segment-1] + Address.Offset);
end
else begin
Symbols.AddObject(Name, TObject(Segments[Address.Segment-1] + Address.Offset));
end;
end;
initialization
Symbols := TStringList.Create;
Symbols.Sorted := True;
Symbols.Duplicates := dupIgnore;
finalization
FreeAndNil(Symbols);
end.
Output on my system (Unitname.Unitname is actually Unitname.Initialization):
0001: System.System
0003: Windows.Windows
0011: SysUtils.SysUtils
0012: VarUtils.VarUtils
0013: Variants.Variants
0014: TypInfo.TypInfo
0016: Classes.Classes
0017: IniFiles.IniFiles
0018: Registry.Registry
0020: Graphics.Graphics
0023: SyncObjs.SyncObjs
0024: UxTheme.UxTheme
0025: MultiMon.MultiMon
0027: ActnList.ActnList
0028: DwmApi.DwmApi
0029: Controls.Controls
0030: Themes.Themes
0032: Menus.Menus
0033: HelpIntfs.HelpIntfs
0034: FlatSB.FlatSB
0036: Printers.Printers
0047: GraphUtil.GraphUtil
0048: ExtCtrls.ExtCtrls
0051: ComCtrls.ComCtrls
0054: Dialogs.Dialogs
0055: Clipbrd.Clipbrd
0057: Forms.Forms
0058: JclResources.JclResources
0059: JclBase.JclBase
0061: JclWin32.JclWin32
0063: ComObj.ComObj
0064: AnsiStrings.AnsiStrings
0065: JclLogic.JclLogic
0066: JclStringConversions.JclStringConversions
0067: JclCharsets.JclCharsets
0068: Jcl8087.Jcl8087
0073: JclIniFiles.JclIniFiles
0074: JclSysInfo.JclSysInfo
0075: JclUnicode.JclUnicode
0076: JclWideStrings.JclWideStrings
0077: JclRegistry.JclRegistry
0078: JclSynch.JclSynch
0079: JclMath.JclMath
0080: JclStreams.JclStreams
0081: JclAnsiStrings.JclAnsiStrings
0082: JclStrings.JclStrings
0083: JclShell.JclShell
0084: JclSecurity.JclSecurity
0085: JclDateTime.JclDateTime
0086: JclFileUtils.JclFileUtils
0087: JclConsole.JclConsole
0088: JclSysUtils.JclSysUtils
0089: JclUnitVersioning.JclUnitVersioning
0090: JclPeImage.JclPeImage
0091: JclTD32.JclTD32
0092: JclHookExcept.JclHookExcept
0093: JclDebug.JclDebug
0094: MainUnit.MainUnit
For units in the interface uses list,
the initialization sections of the
units used by a client are executed in
the order in which the units appear in
the client's uses clause.
see Online Help \ Programs and Units \ The Initialization Section and this article: Understanding Delphi Unit initialization order
ICARUS computes the Runtime initialization order for its Uses Report:
This section lists the order in which the initialization sections are executed at runtime.
You might check out the unit System and SysInit and look for the procedure InitUnits. Here you see that every module compiled with Delphi has a list of units initialization and finalization pointers. Using those plus a map file might give you the exact initialization order, but it will take some pointer hackery.
How about adding
OutputDebugString('In MyUnit initialization');
to the initialization sections?
You can set breakpoints on all initialization sections that don't break but write a message to the debugger log. It will give you the same list as adding OutputDebugString('...') calls but without having to modify the source code of all units.