I want to find a way to know that a form was created at run time (or destroyed).
This for Delphi or fpc.
Many thanks
PS : Is there a way to retrieve that info for all objects ?
I want to have a event that tells me that a new object was just created at run time (or destroyed).
There are no built in events that fire whenever an object is created or destroyed.
Because I like writing code hooks, I offer the following unit. This hooks the _AfterConstruction method in the System unit. Ideally it should use a trampoline but I've never learnt how to implement those. If you used a real hooking library you'd be able to do it better. Anyway, here it is:
unit AfterConstructionEvent;
interface
var
OnAfterConstruction: procedure(Instance: TObject);
implementation
uses
Windows;
procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
OldProtect: DWORD;
begin
if VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then
begin
Move(NewCode, Address^, Size);
FlushInstructionCache(GetCurrentProcess, Address, Size);
VirtualProtect(Address, Size, OldProtect, #OldProtect);
end;
end;
type
PInstruction = ^TInstruction;
TInstruction = packed record
Opcode: Byte;
Offset: Integer;
end;
procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
NewCode: TInstruction;
begin
NewCode.Opcode := $E9;//jump relative
NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;
function System_AfterConstruction: Pointer;
asm
MOV EAX, offset System.#AfterConstruction
end;
function System_BeforeDestruction: Pointer;
asm
MOV EAX, offset System.#BeforeDestruction
end;
var
_BeforeDestruction: procedure(const Instance: TObject; OuterMost: ShortInt);
function _AfterConstruction(const Instance: TObject): TObject;
begin
try
Instance.AfterConstruction;
Result := Instance;
if Assigned(OnAfterConstruction) then
OnAfterConstruction(Instance);
except
_BeforeDestruction(Instance, 1);
raise;
end;
end;
initialization
#_BeforeDestruction := System_BeforeDestruction;
RedirectProcedure(System_AfterConstruction, #_AfterConstruction);
end.
Assign a handler to OnAfterConstruction and that handler will be called whenever an object is created.
I leave it as an exercise to the reader to add an OnBeforeDestruction event handler.
Note that I am not saying that such an approach is a good thing to do. I'm just answering the direct question that you asked. You can decide for yourself whether or not you want to use this. I know I would not do so!
Use TForm's OnCreate event to inform whoever you want in whatever way you want.
In MS Windows you can hook events of your process using this small template:
{$mode objfpc}{$H+}
uses
Windows, JwaWinUser;
function ShellProc(nCode: longint; wParam: WPARAM; lParam: LPARAM): longint; stdcall;
var
wnd: HWND;
begin
Result := 0;
case nCode of
HSHELL_WINDOWCREATED:
begin
wnd := wParam;
// Check window
// Get task handle
// Get window icon
// Add task to the list
// Call event
end;
HSHELL_WINDOWDESTROYED:
begin
wnd := wParam;
// Check window
// Get task handle
// Get window icon
// Remove task to the list
// Call event
end;
HSHELL_LANGUAGE:
begin
// Get language
// Call event
end;
HSHELL_REDRAW:
begin
// Call event
end;
HSHELL_WINDOWACTIVATED:
begin
// Get language
// Call event
end;
//HSHELL_APPCOMMAND:
//begin
// { TODO 1 -ond -csys : Specify return value for this code }
// Result := -1;
//end;
end;
// Call next hook in the chain
Result := CallNextHookEx(
0,
nCode,
wParam,
lParam);
end;
var
FCallbackProc: HOOKPROC;
function InitShellHook(AProc: HOOKPROC): HHOOK; stdcall; export;
begin
FCallbackProc := AProc;
Result := SetWindowsHookEx(WH_SHELL, #ShellProc, 0, 0);
end;
procedure DoneShellHook(AHook: HHOOK); stdcall; export;
begin
UnhookWindowsHookEx(AHook);
end;
HSHELL_WINDOWCREATED will inform you that your process was create new window.
Call InitShellHook with your procedure address (see HOOCPROC declaration).
Related
I have an old Delphi VCL project build in Rad Studio 2007. This version contains a bug in the TScreen.FindMonitor method. I am trying to fix this using a seperate helper class like stated in Is there a runtime patch for AV in TMonitor.GetBoundsRect?.
The only problem is that I can't get this to work. Delphi can't compile and gives error "Cannot access private symbol TScreen.FindMonitor".
Also tried using a WITH self DO statement, casting self to TScreen, casting to pointer and using MethodAddress, but nothing seems to work.
My code
unit PatchTScreen;
interface
implementation
uses
Types, MultiMon, Windows, Forms;
type
TFindMonitorMethod = function(Handle: HMONITOR): TMonitor of object;
TScreenHelper = class helper for TScreen
private
function FindMonitorAddress: Pointer;
function PatchedFindMonitorAddress: Pointer;
function PatchedFindMonitor(Handle: HMONITOR): TMonitor;
end;
function TScreenHelper.FindMonitorAddress: Pointer;
var
MethodPtr: TFindMonitorMethod;
begin
MethodPtr := Self.FindMonitor;
Result := TMethod(MethodPtr).Code;
end;
function TScreenHelper.PatchedFindMonitorAddress: Pointer;
var
MethodPtr: TFindMonitorMethod;
begin
MethodPtr := Self.PatchedFindMonitor;
Result := TMethod(MethodPtr).Code;
end;
function TScreenHelper.PatchedFindMonitor(Handle: HMONITOR): TMonitor;
function DoFindMonitor: TMonitor;
var
I: Integer;
begin
Result := nil;
for I := 0 to MonitorCount - 1 do
if Monitors[I].Handle = Handle then
begin
Result := Monitors[I];
Break;
end;
end;
begin
Result := DoFindMonitor;
if Result = nil then
begin
// If we didn't find the monitor, rebuild the list (it may have changeed)
Self.GetMonitors;
Result := DoFindMonitor;
end;
end;
procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
OldProtect: DWORD;
begin
if VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then
begin
Move(NewCode, Address^, Size);
FlushInstructionCache(GetCurrentProcess, Address, Size);
VirtualProtect(Address, Size, OldProtect, #OldProtect);
end;
end;
type
PInstruction = ^TInstruction;
TInstruction = packed record
Opcode: Byte;
Offset: Integer;
end;
procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
NewCode: TInstruction;
begin
NewCode.Opcode := $E9;//jump relative
NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;
initialization
RedirectProcedure(
TScreen(nil).FindMonitorAddress, // safe to use nil, don't need to instantiate an object
TScreen(nil).PatchedFindMonitorAddress // likewise
);
end.
The compile error occures in TScreenHelper.FindMonitorAddress.
The only way I have been able to fix this issue is by changing the original Delphi code of TScreen.FindMonitor in Forms.pas and recomipling the unit with my project. But this is not an actual solution I would like to use, because other developers must make the same changes etc.
The following is a known bug in Delphi 7 and 2007 (and possibly other versions)
Does TMonitor.GetBoundsRect have an access violation bug in Delphi 2007 triggered by VNC?
There is an answer on how to fix it by recompiling forms.pas but I'd rather not recompile RTL units. Has anybody created a runtime patch for it e.g. using the technique also used in Andy Hausladen's VclFixpack?
(And if yes, would you please share it with us?)
You can do this with a detour. For instance, the code given in this answer: https://stackoverflow.com/a/8978266/505088 will suffice. Or you could opt for any other detouring library.
Beyond that, you need to crack the class to gain access to the private members. After all, GetBoundsRect is private. You can crack the class with a class helper. Again, one of my answers shows how to do that: https://stackoverflow.com/a/10156682/505088
Put the two together, and you have your answer.
unit PatchTScreen;
interface
implementation
uses
Types, MultiMon, Windows, Forms;
type
TScreenHelper = class helper for TScreen
function FindMonitorAddress: Pointer;
function PatchedFindMonitorAddress: Pointer;
function PatchedFindMonitor(Handle: HMONITOR): TMonitor;
end;
function TScreenHelper.FindMonitorAddress: Pointer;
var
MethodPtr: function(Handle: HMONITOR): TMonitor of object;
begin
MethodPtr := Self.FindMonitor;
Result := TMethod(MethodPtr).Code;
end;
function TScreenHelper.PatchedFindMonitorAddress: Pointer;
var
MethodPtr: function(Handle: HMONITOR): TMonitor of object;
begin
MethodPtr := Self.PatchedFindMonitor;
Result := TMethod(MethodPtr).Code;
end;
function TScreenHelper.PatchedFindMonitor(Handle: HMONITOR): TMonitor;
var
I: Integer;
begin
Result := nil;
for I := 0 to MonitorCount - 1 do
if Monitors[I].Handle = Handle then
begin
Result := Monitors[I];
// break;
Exit;
end;
//if we get here, the Monitors array has changed, so we need to clear and reinitialize it
for i := 0 to MonitorCount-1 do
TMonitor(Monitors[i]).Free;
fMonitors.Clear;
EnumDisplayMonitors(0, nil, #EnumMonitorsProc, LongInt(FMonitors));
for I := 0 to MonitorCount - 1 do
if Monitors[I].Handle = Handle then
begin
Result := Monitors[I];
Exit;
end;
end;
procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
OldProtect: DWORD;
begin
if VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then
begin
Move(NewCode, Address^, Size);
FlushInstructionCache(GetCurrentProcess, Address, Size);
VirtualProtect(Address, Size, OldProtect, #OldProtect);
end;
end;
type
PInstruction = ^TInstruction;
TInstruction = packed record
Opcode: Byte;
Offset: Integer;
end;
procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
NewCode: TInstruction;
begin
NewCode.Opcode := $E9;//jump relative
NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;
initialization
RedirectProcedure(
TScreen(nil).FindMonitorAddress, // safe to use nil, don't need to instantiate an object
TScreen(nil).PatchedFindMonitorAddress // likewise
);
end.
Without class helpers, as is the case in Delphi 7, you might be best recompiling the VCL unit in question. That is simple and robust.
If you can't bring yourself to do that then you need to find the function address. I'd do that by disassembling the code at runtime and following it to a known call to the function. This technique is well demonstrated by madExcept.
I am using XE7 64 and I am looking for a strategy to solve several problems I am having when displaying HTMLHelp files from within my applications (I have added the HTMLHelpViewer to my uses clause). The issues are the following: 1) Ctrl-c does not copy text from topics; 2) The helpviewer cannot be accessed when a modal dialog is active.
The source of the problems are presumably attributable to the htmlhelpviewer running in the same process as the application. Is there a way to have the built-in htmlhelpviewer launch a new process? If not, then will I need to launch HH.EXE with Createprocess?
You could launch the help file viewer as a separate process, but I think that will make controlling it even more complex. My guess is that the supplied HTML help viewer code is the root cause of your problems. I've always found that code to be extremely low quality.
I deal with that by implementing an OnHelp event handler that I attach to the Application object. This event handler calls the HtmlHelp API directly. I certainly don't experience any of the problems that you describe.
My code looks like this:
unit Help;
interface
uses
SysUtils, Classes, Windows, Messages, Forms;
procedure ShowHelp(HelpContext: THelpContext);
procedure CloseHelpWindow;
implementation
function RegisterShellHookWindow(hWnd: HWND): BOOL; stdcall; external user32;
function DeregisterShellHookWindow(hWnd: HWND): BOOL; stdcall; external user32;
procedure ShowHelp(HelpContext: THelpContext);
begin
Application.HelpCommand(HELP_CONTEXTPOPUP, HelpContext);
end;
type
THelpWindowManager = class
private
FMessageWindow: HWND;
FHelpWindow: HWND;
FHelpWindowLayoutPreference: TFormLayoutPreference;
function ApplicationHelp(Command: Word; Data: THelpEventData; var CallHelp: Boolean): Boolean;
protected
procedure WndProc(var Message: TMessage);
public
constructor Create;
destructor Destroy; override;
procedure RestorePosition;
procedure StorePosition;
procedure StorePositionAndClose;
end;
{ THelpWindowManager }
constructor THelpWindowManager.Create;
function DefaultRect: TRect;
var
i, xMargin, yMargin: Integer;
Monitor: TMonitor;
begin
Result := Rect(20, 20, 1000, 700);
for i := 0 to Screen.MonitorCount-1 do begin
Monitor := Screen.Monitors[i];
if Monitor.Primary then begin
Result := Monitor.WorkareaRect;
xMargin := Monitor.Width div 20;
yMargin := Monitor.Height div 20;
inc(Result.Left, xMargin);
dec(Result.Right, xMargin);
inc(Result.Top, yMargin);
dec(Result.Bottom, yMargin);
break;
end;
end;
end;
begin
inherited;
FHelpWindowLayoutPreference := TFormLayoutPreference.Create('Help Window', DefaultRect, False);
FMessageWindow := AllocateHWnd(WndProc);
RegisterShellHookWindow(FMessageWindow);
Application.OnHelp := ApplicationHelp;
end;
destructor THelpWindowManager.Destroy;
begin
StorePositionAndClose;
Application.OnHelp := nil;
DeregisterShellHookWindow(FMessageWindow);
DeallocateHWnd(FMessageWindow);
FreeAndNil(FHelpWindowLayoutPreference);
inherited;
end;
function THelpWindowManager.ApplicationHelp(Command: Word; Data: THelpEventData; var CallHelp: Boolean): Boolean;
var
hWndCaller: HWND;
HelpFile: string;
DoSetPosition: Boolean;
begin
CallHelp := False;
Result := True;
//argh, WinHelp commands
case Command of
HELP_CONTEXT,HELP_CONTEXTPOPUP:
begin
hWndCaller := GetDesktopWindow;
HelpFile := Application.HelpFile;
DoSetPosition := FHelpWindow=0;//i.e. if the window is not currently showing
FHelpWindow := HtmlHelp(hWndCaller, HelpFile, HH_HELP_CONTEXT, Data);
if FHelpWindow=0 then begin
//the topic may not have been found because the help file isn't there...
if FileExists(HelpFile) then begin
ReportError('Cannot find help topic for selected item.'+sLineBreak+sLineBreak+'Please report this error message to Orcina.');
end else begin
ReportErrorFmt(
'Cannot find help file (%s).'+sLineBreak+sLineBreak+'Reinstalling the program may fix this problem. '+
'If not then please contact Orcina for assistance.',
[HelpFile]
);
end;
end else begin
if DoSetPosition then begin
RestorePosition;
end;
HtmlHelp(hWndCaller, HelpFile, HH_DISPLAY_TOC, 0);//ensure that table of contents is showing
end;
end;
end;
end;
procedure THelpWindowManager.RestorePosition;
begin
if FHelpWindow<>0 then begin
RestoreWindowPosition(FHelpWindow, FHelpWindowLayoutPreference);
end;
end;
procedure THelpWindowManager.StorePosition;
begin
if FHelpWindow<>0 then begin
StoreWindowPosition(FHelpWindow, FHelpWindowLayoutPreference);
end;
end;
procedure THelpWindowManager.StorePositionAndClose;
begin
if FHelpWindow<>0 then begin
StorePosition;
SendMessage(FHelpWindow, WM_CLOSE, 0, 0);
FHelpWindow := 0;
end;
end;
var
WM_SHELLHOOKMESSAGE: UINT;
procedure THelpWindowManager.WndProc(var Message: TMessage);
begin
if (Message.Msg=WM_SHELLHOOKMESSAGE) and (Message.WParam=HSHELL_WINDOWDESTROYED) then begin
//need cast to HWND to avoid range errors
if (FHelpWindow<>0) and (HWND(Message.LParam)=FHelpWindow) then begin
StorePosition;
FHelpWindow := 0;
end;
end;
Message.Result := DefWindowProc(FMessageWindow, Message.Msg, Message.wParam, Message.lParam);
end;
var
HelpWindowManager: THelpWindowManager;
procedure CloseHelpWindow;
begin
HelpWindowManager.StorePositionAndClose;
end;
initialization
if not ModuleIsPackage then begin
Application.HelpFile := ChangeFileExt(Application.ExeName, '.chm');
WM_SHELLHOOKMESSAGE := RegisterWindowMessage('SHELLHOOK');
HelpWindowManager := THelpWindowManager.Create;
end;
finalization
FreeAndNil(HelpWindowManager);
end.
Include that unit in your project and you will be hooked up to handle help context requests. Some comments on the code:
The implementation of the OnHelp event handler is limited to just my needs. Should you need more functionality you'd have to add it yourself.
You won't have TFormLayoutPrefernce. It's one of my preference classes that manages per-user preferences. It stores away the window's bounds rectangle, and whether or not the window was maximised. This is used to ensure that the help window is shown at the same location as it was shown in the previous session. If you don't want such functionality, strip it away.
ReportError and ReportErrorFmt are my helper functions to show error dialogs. You can replace those with calls to MessageBox or similar.
Based on David's comments that he calls HtmlHelp directly and does not encounter the problems noted above, I tried that approach and it solved the problems. Example of calling HTMLHelp directly to open a topic by id:
HtmlHelp(Application.Handle,'d:\help study\MyHelp.chm',
HH_HELP_CONTEXT, 70);
I'd like to detect when a new form has been created.
Now I use the Screen.ActiveFormChange event and check for new forms in Screen.CustomForms but ActiveFormChange is fired after the OnShow event of the form.
I'd like to detect the form even before OnShow was fired. Is there any way to do this without modifying the Vcl.Forms unit?
I'd like to detect all forms (also Delphi modal messages etc.) therefore inheriting all forms from a custom class is not possible (correct me if I am wrong).
Alternatively, is it possible to detect that a new component was added to some TComponent.FComponents list?
You can use the SetWindowsHookEx function to install a WH_CBT Hook, then you must implement a CBTProc callback function and finally intercept one of the possible code values for this hook. in this case you can try with HCBT_ACTIVATE or HCBT_CREATEWND.
Check this sample for the HCBT_ACTIVATE Code.
var
hhk: HHOOK;
function CBT_FUNC(nCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
const
ClassNameBufferSize = 1024;
var
hWindow: HWND;
RetVal : Integer;
ClassNameBuffer: Array[0..ClassNameBufferSize-1] of Char;
begin
Result := CallNextHookEx(hhk, nCode, wParam, lParam);
if nCode<0 then exit;
case nCode of
HCBT_ACTIVATE:
begin
hWindow := HWND(wParam);
if (hWindow>0) then
begin
RetVal := GetClassName(wParam, ClassNameBuffer, SizeOf(ClassNameBuffer));
if RetVal>0 then
begin
//do something
OutputDebugString(ClassNameBuffer);
end;
end;
end;
end;
end;
Procedure InitHook();
var
dwThreadID : DWORD;
begin
dwThreadID := GetCurrentThreadId;
hhk := SetWindowsHookEx(WH_CBT, #CBT_FUNC, hInstance, dwThreadID);
if hhk=0 then RaiseLastOSError;
end;
Procedure KillHook();
begin
if (hhk <> 0) then
UnhookWindowsHookEx(hhk);
end;
initialization
InitHook();
finalization
KillHook();
end.
Note : if you uses the HCBT_CREATEWND code instead you will
intercept any window created by the system not just "forms".
Track Screen.CustomFormCount in Application.OnIdle:
private
FPrevFormCount: Integer;
end;
procedure TForm1.ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
begin
if Screen.CustomFormCount > FPrevFormCount then
Caption := Caption + ' +1';
if Screen.CustomFormCount <> FPrevFormCount then
FPrevFormCount := Screen.CustomFormCount;
end;
procedure TForm1.TestButton1Click(Sender: TObject);
begin
TForm2.Create(Self).Show;
end;
procedure TForm1.TestButton2Click(Sender: TObject);
begin
ShowMessage('Also trackable?'); // Yes!
end;
procedure TForm1.TestButton3Click(Sender: TObject);
begin
OpenDialog1.Execute; // Doesn't update Screen.CustomFormCount
end;
Native dialogs managed and shown by Windows (TOpenDialog, TFontDialog, etc...) are created apart from the VCL and to track them also, you need a hacking unit. Try this one then.
Thanks to David I found a solution: The clue is to replace Screen.AddForm method with your own. The way how to do it is described in these SO answers:
How I can patch a private method of a delphi class?
How to change the implementation (detour) of an externally declared function
Patch routine call in delphi
Thanks again!
I am using Delphi 2007. I can successfully Post data to a web site using WebBrowser.Navigate, but afterwards, when that site returns a PDF, while it appears on the screen of the Browser, I cannot figure out how to acquire the PDF programmatically. I can see some text and HTML using Document.Body.InnerHTML, but not the PDF. Can someone demonstrate how to acquire the PDF which appears after the POST?
Thank yoU!
To get the text out of a PDF in the web browser, I found a solution using an open source unit called PushKeys to send keys to the web browser to select all the text (Control+A), copy it to the clipboard (Control+C) and then paste it to a TMemo or other control using PasteFromClipBoard. Tested in D2007.
WebBrowser.SetFocus; // set the focus to the TWebBrowser control
Sleep(1000); // 1 second delay to be sure webbrowser actually has focus
Application.ProcessMessages;
PushKeys('^a'); //send ctrl-a to select all text
Application.ProcessMessages;
WebBrowser.SetFocus;
PushKeys('^c'); //send ctrl-c to copy the text to clipboard
Sleep(1000); // 1 second delay to make sure clipboard finishes processing
Application.ProcessMessages;
Memo1.PasteFromClipBoard; // Paste the clipboard to a memo field.
// You could also use the clipbrd unit to handle the data.
//for Multi-page PDF's, you can send a PageDn key to get to the next page:
PushFnKey('PAGEDOWN');
You could use an IE4+ option for capturing all internet traffic using your own protocol. You can even hook the protocol http (IIRC) and when you need to load the data use the WIndows functions and/or Indy components.
This is a unit to do so:
{
This component allows you to dynamically create your own internet protocols for
Microsoft Internet Explorer 4+. Simply place the component on your form, set the protocol
property to something useful and set the Active property.
For example, when the Protocol is set to 'private', you can trap requests to
'private:anythingyoulike'.
}
unit UnitInternetProtocol;
// Developed by: R.A. Hornstra
// (C) 2001 ContinuIT BV
interface
uses
SysUtils, Windows, Classes, Messages;
type
TInternetProtocol = class;
{
When a request is made, the data must be returned in a TStream descendant.
The request is present in Request. The result should be saved in Stream.
When no data can be linked to the request, leave Stream equal to nil.
See #link(TInternetProtocol.OnRequestStream) and #link(TInternetProtocol.OnReleaseStream).
}
TProtocolRequest = procedure(Sender: TInternetProtocol; const Request: string;
var Stream: TStream) of object;
{
When a request is done by the Microsoft Internet Explorer it is done via an URL.
This URL starts with a protocol, than a colon and than a protocol specific resource identifier.
New protocols can be added dynamically and privately for each session.
This component will register / deregister new protocols to the Microsoft Internet Explorer.
You should set the name of the protocol with #link(Protocol), activate / deactivate the
protocol with #link(Active). The implementation of the protocol can be done with the
events #link(OnRequestStream) and #link(OnReleaseStream).
}
TInternetProtocol = class(TComponent)
private
FHandle: HWnd;
FActive: Boolean;
FProtocol: string;
FRequest: TProtocolRequest;
FRelease: TProtocolRequest;
procedure SetActive(const Value: Boolean);
procedure SetProtocol(const Value: string);
protected
procedure Loaded; override;
procedure Activate;
procedure Deactivate;
procedure WndProc(var Message: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{
Setting this property will activate or deactivate the internet
}
property Active: Boolean read FActive write SetActive;
{
The protocol name must be specified. default, this is 'private'.
You should fill it here without the trailing colon (that's part of the URL notation).
Protocol names should be valid identifiers.
}
property Protocol: string read FProtocol write SetProtocol;
{
When a request is made on the selected protocol, this event is fired.
It should return a TStream, based upon the given Request.
The default behaviour of TInternetProtocol is freeing the stream.
To override or monitor this behaviour, use #link(OnRequestStream).
}
property OnRequestStream: TProtocolRequest read FRequest write FRequest;
{
When a stream is about to be released by TInternetProtocol, you can override the
default behaviour. By Setting the Stream variable to nil in the OnReleaseStream handler,
the stream will not be released by TInternetProtocol.
This is handy when you're implementing a caching system, or for some reason need control on
the creation and deletion to the streams.
The default behaviour of TInternetProtocol is freeing the stream.
}
property OnReleaseStream: TProtocolRequest read FRelease write FRelease;
end;
{
All exceptions raised by #link(TInternetProtocol) are of type EInternetException.
}
EInternetException = class(Exception);
procedure Register;
implementation
uses
ComObj, ActiveX, UrlMon, Forms;
resourcestring
strNotAValidProtocol = 'The Internet Protocol selected is not a valid protocol identifier';
// todo: move registration to separate file
procedure Register;
begin
Classes.RegisterComponents('Internet',[TInternetProtocol]);
end;
// forward declarations
procedure RegisterProtocol(Protocol: string; Handler: TInternetProtocol); forward;
procedure UnregisterProtocol(Protocol: string); forward;
const
IID_TInternetProtocolHandler: TGUID = '{B74826E0-1107-11D5-B166-0010D7090486}';
WM_STREAMNEEDED = WM_USER;
{ TInternetProtocol }
constructor TInternetProtocol.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FActive := False;
FProtocol := 'private';
FRequest := nil;
FRelease := nil;
FHandle := Forms.AllocateHWnd(WndProc);
end;
destructor TInternetProtocol.Destroy;
begin
Active := False;
Forms.DeallocateHWnd(FHandle);
inherited Destroy;
end;
procedure TInternetProtocol.Loaded;
begin
inherited Loaded;
if FActive then Activate;
end;
procedure TInternetProtocol.SetActive(const Value: Boolean);
begin
if Value = FActive then Exit;
if Value then begin
if not (csLoading in ComponentState) then Activate;
end else begin
Deactivate;
end;
FActive := Value;
end;
procedure TInternetProtocol.Activate;
begin
if csDesigning in ComponentState then Exit;
RegisterProtocol(FProtocol,Self);
end;
procedure TInternetProtocol.Deactivate;
begin
if csDesigning in ComponentState then Exit;
UnregisterProtocol(FProtocol);
end;
procedure TInternetProtocol.SetProtocol(const Value: string);
var AActive: Boolean;
begin
if not SysUtils.IsValidIdent(Value) then raise EInternetException.Create(strNotAValidProtocol);
AActive := FActive;
try
Active := False;
FProtocol := Value;
finally
Active := AActive;
end;
end;
procedure TInternetProtocol.WndProc(var Message: TMessage);
var
Msg: packed record
Msg: Longword;
Request: PChar;
Stream: ^TStream;
end;
begin
if Message.Msg = WM_STREAMNEEDED then begin
System.Move(Message,Msg,SizeOf(Msg));
if Assigned(FRequest) then FRequest(Self,string(Msg.Request),Msg.Stream^);
end else Message.Result := Windows.DefWindowProc(FHandle,Message.Msg,Message.WParam,Message.LParam);
end;
var
Session: IInternetSession; // The current Internet Session
Factory: IClassFactory; // Factory of our IInternetProtocol implementation
Lock: TRTLCriticalSection; // The lock for thread safety
List: TStrings; // The list of active protocol handlers
type
TInternetProtocolHandler = class(TInterfacedObject, IInternetProtocol)
private
ProtSink: IInternetProtocolSink; // Protocol Sink that needs the data
Stream: TStream; // Stream containing the data
StreamPosition: Integer; // Current Position in the stream
StreamSize: Integer; // Current size of the stream
LockCount: Integer; // Lock count for releasing data
procedure ReleaseStream;
public
{ IInternetProtocol }
function Start(szUrl: PWideChar; OIProtSink: IInternetProtocolSink;
OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult; stdcall;
function Continue(const ProtocolData: TProtocolData): HResult; stdcall;
function Abort(hrReason: HResult; dwOptions: DWORD): HResult; stdcall;
function Terminate(dwOptions: DWORD): HResult; stdcall;
function Suspend: HResult; stdcall;
function Resume: HResult; stdcall;
function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall;
function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;
out libNewPosition: ULARGE_INTEGER): HResult; stdcall;
function LockRequest(dwOptions: DWORD): HResult; stdcall;
function UnlockRequest: HResult; stdcall;
end;
TInternetProtocolHandlerFactory = class(TInterfacedObject, IClassFactory)
public
{ IClassFactory }
function CreateInstance(const unkOuter: IUnknown; const iid: TIID; out obj): HResult; stdcall;
function LockServer(fLock: BOOL): HResult; stdcall;
end;
procedure RegisterProtocol(Protocol: string; Handler: TInternetProtocol);
var
i: Integer;
Proto: WideString;
begin
Windows.EnterCriticalSection(Lock);
try
// if we have a previous handler, delete that from the list.
i := List.IndexOf(Protocol);
if i >=0 then TInternetProtocol(List.Objects[i]).Active := False;
// If this is the first time, create the Factory and get the Internet Session object
if List.Count = 0 then begin
Factory := TInternetProtocolHandlerFactory.Create;
CoInternetGetSession(0, Session, 0);
end;
// Append ourselves to the list
List.AddObject(Protocol,Handler);
// Register the protocol with the Internet session
Proto := Protocol;
Session.RegisterNameSpace(Factory, IInternetProtocol{ IID_TInternetProtocolHandler}, PWideChar(Proto), 0, nil, 0);
finally
Windows.LeaveCriticalSection(Lock);
end;
end;
procedure UnregisterProtocol(Protocol: string);
var i: Integer;
Proto: WideString;
begin
Windows.EnterCriticalSection(Lock);
try
i := List.IndexOf(Protocol);
if i < 0 then Exit; // oops, protocol was somehow already freed... this should not happen
// unregister our namespace handler
Proto := Protocol; // to widestring
Session.UnregisterNameSpace(Factory, PWideChar(Proto));
// and free from list
List.Delete(i);
// see if we need to cleanup?
if List.Count = 0 then begin
// release the COM server
Session := nil;
Factory := nil;
end;
finally
Windows.LeaveCriticalSection(Lock);
end;
end;
{ TInternetProtocolHandler }
function TInternetProtocolHandler.Abort(hrReason: HResult; dwOptions: DWORD): HResult;
begin
Result := E_NOTIMPL;
end;
function TInternetProtocolHandler.Continue(const ProtocolData: TProtocolData): HResult;
begin
Result := S_OK;
end;
function TInternetProtocolHandler.LockRequest(dwOptions: DWORD): HResult;
begin
Inc(LockCount);
Result := S_OK;
end;
function TInternetProtocolHandler.Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult;
const Results: array [Boolean] of Longword = ( E_PENDING, S_FALSE );
begin
if Assigned(Stream) then cbRead := Stream.Read(pv^,cb) else cbRead := 0;
Inc(StreamPosition, cbread);
Result := Results[StreamPosition = StreamSize];
end;
procedure TInternetProtocolHandler.ReleaseStream;
begin
// see if we can release the Stream...
if Assigned(Stream) then FreeAndNil(Stream);
Protsink := nil;
end;
function TInternetProtocolHandler.Resume: HResult;
begin
Result := E_NOTIMPL;
end;
function TInternetProtocolHandler.Seek(dlibMove: LARGE_INTEGER;
dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult;
begin
Result := E_NOTIMPL;
end;
function TInternetProtocolHandler.Start(szUrl: PWideChar; OIProtSink: IInternetProtocolSink;
OIBindInfo: IInternetBindInfo; grfPI,dwReserved: DWORD): HResult;
var URL, Proto: string;
i: Integer;
Handler: TInternetProtocol;
begin
// Sanity check.
Assert(Assigned(OIProtSink));
Assert(Assigned(szUrl));
Assert(Assigned(OIBindInfo));
URL := szUrl;
Stream := nil; // just to make sure...
// Clip the protocol name from the URL & change the URL to the proto specific part
i := Pos(':',URL);
if i > 0 then begin
Proto := Copy(URL,1,i-1);
URL := Copy(URL,i+1,MaxInt);
end;
Windows.EnterCriticalSection(Lock);
try
i := List.IndexOf(Proto);
if i >= 0 then begin
// we've found our protocol
Handler := TInternetProtocol(List.Objects[i]);
// And query. Use a Windows message for thread synchronization
Windows.SendMessage(Handler.FHandle,WM_STREAMNEEDED,WParam(PChar(URL)),LParam(#Stream));
end;
finally
Windows.LeaveCriticalSection(Lock);
end;
if not Assigned(Stream) then begin
Result := INET_E_USE_DEFAULT_PROTOCOLHANDLER;
Exit;
end;
// Setup all data
StreamSize := Stream.Size;
Stream.Position := 0;
StreamPosition := 0;
LockCount := 1;
// Get the protocol sink & start the 'downloading' process
ProtSink := OIProtSink;
ProtSink.ReportData(BSCF_FIRSTDATANOTIFICATION or BSCF_LASTDATANOTIFICATION or
BSCF_DATAFULLYAVAILABLE, StreamSize, StreamSize);
ProtSink.ReportResult(S_OK, S_OK, nil);
Result := S_OK;
end;
function TInternetProtocolHandler.Suspend: HResult;
begin
Result := E_NOTIMPL;
end;
function TInternetProtocolHandler.Terminate(dwOptions: DWORD): HResult;
begin
Dec(LockCount);
if LockCount = 0 then ReleaseStream;
Result := S_OK;
end;
function TInternetProtocolHandler.UnlockRequest: HResult;
begin
Dec(LockCount);
if LockCount = 0 then ReleaseStream;
Result := S_OK;
end;
{ TInternetProtocolHandlerFactory }
function TInternetProtocolHandlerFactory.CreateInstance(const unkOuter: IInterface;
const iid: TIID; out obj): HResult;
begin
if IsEqualGUID(iid, IInternetProtocol) then begin
IInternetProtocol(obj) := TInternetProtocolHandler.Create as IInternetProtocol;
Result := S_OK;
end else if IsEqualGUID(iid, IInterface) then begin
IInterface(obj) := TInternetProtocolHandler.Create as IInterface;
Result := S_OK;
end else begin
Result := E_NOINTERFACE;
end;
end;
function TInternetProtocolHandlerFactory.LockServer(fLock: BOOL): HResult;
begin
if fLock then _AddRef else _Release;
Result := S_OK;
end;
initialization
begin
// Get a critical section for thread synchro
Windows.InitializeCriticalSection(Lock);
// The list of protocol handlers
List := TStringList.Create;
end;
finalization
begin
// deactivate all handlers (should only happen when memory leaks are present...)
while List.Count > 0 do TInternetProtocol(List.Objects[0]).Active := False;
List.Free;
// and delete the critical section
Windows.DeleteCriticalSection(Lock);
end;
end.