Enumerating DOM nodes in TChromium - delphi

I am trying to enumerate DOM nodes using the following code (under XE2).
I have borrowed most of this from answers given here in SO, but for some reason it's not doing anything.
IOW, ProcessDOM() is not ever getting called.
And, I am at my wits end.
Could someone show me what I am doing wrong here.
Thanks in advance.
procedure ProcessNode(ANode: ICefDomNode);
var
Node1: ICefDomNode;
begin
if Assigned(ANode) then begin
Node1 := ANode.FirstChild;
while Assigned(Node1) do begin
{Do stuff with node}
ProcessNode(Node1);
Node1 := Node1.NextSibling;
end;
end;
end;
procedure ProcessDOM(const ADocument: ICefDomDocument);
begin
ProcessNode(ADocument.Body);
end;
procedure TMainForm.Chrome1LoadEnd(Sender: TObject; const ABrowser: ICefABrowser; const AFrame: ICefAFrame; AStatus: Integer);
begin
if Assigned(AFrame) then AFrame.VisitDomProc(ProcessDOM);
end;

I had the same problem and I used the demo guiclient it comes with dcef3. With the following it works.
type TCustomRenderProcessHandler = class(TCefRenderProcessHandlerOwn)
protected
function OnProcessMessageReceived(const browser: ICefBrowser; sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; override;
end;
Chromium1.browser.SendProcessMessage(PID_RENDERER, TCefProcessMessageRef.New('visitdom'));
function TCustomRenderProcessHandler.OnProcessMessageReceived(browser: ICefBrowser; sourceProcess: TCefProcessId; message: ICefProcessMessage): Boolean;
begin
if (message.Name = 'visitdom') then begin
browser.MainFrame.VisitDomProc(
procedure(const doc: ICefDomDocument)
begin
ProcessNode(Doc.Body);
end);
Result := True;
end;
end;
initialization
CefRenderProcessHandler := TCustomRenderProcessHandler.Create;

You need to add a procedure to the handler.
procedure ProcessNode(ANode: ICefDomNode);
Read this: 1

As this blog point out, The main difficulty when accessing a rendered page's DOM is that you can only do so in the same process as the associated renderer for that page.
You can't access dom from browser thread, you have to do it in renderer thread.
First, Forward a message (like visitdom) from browser process to rendering process
procedure TMainForm.crmLoadEnd(Sender: TObject; const browser: ICefBrowser;
const frame: ICefFrame; httpStatusCode: Integer);
var
msg : ICefProcessMessage;
begin
if IsMain(browser, frame) then
FLoading := False;
msg := TCefProcessMessageRef.New('visitdom');
browser.SendProcessMessage(PID_RENDERER, msg);
end;
Second, create a TCustomRenderProcessHandler to handle the message, send the result back to the browser processs.
function TCustomRenderProcessHandler.OnProcessMessageReceived(
const browser: ICefBrowser; sourceProcess: TCefProcessId;
const message: ICefProcessMessage): Boolean;
begin
Result := False;
if (message.Name = 'visitdom') then
begin
browser.MainFrame.VisitDomProc(
procedure(const doc: ICefDomDocument)
function ProcessNode(ANode: ICefDomNode) : String;
var
Node: ICefDomNode;
begin
Result := 'Not Found';
if Assigned(ANode) then
begin
Node := ANode.FirstChild;
while Assigned(Node) do
begin
if Node.ElementTagName='DIV' then
begin
if Node.GetElementAttribute('class')='tv-panels' then
begin
Result := 'Found';
Exit;
end;
end;
ProcessNode(Node);
Node := Node.NextSibling;
end;
end;
end;
var msg : ICefProcessMessage;
begin
msg := TCefProcessMessageRef.New('visitdom');
msg.ArgumentList.SetString(0, processNode(doc.Body));
browser.SendProcessMessage(PID_BROWSER, msg);
end);
Result := True;
end;
end;
Third, On browser process, create an handler to process the messenage sent back from render process.
procedure TMainForm.crmProcessMessageReceived(Sender: TObject;
const browser: ICefBrowser; sourceProcess: TCefProcessId;
const message: ICefProcessMessage; out Result: Boolean);
begin
Result := False;
if (message.Name = 'visitdom') then
begin
StatusBar.SimpleText := message.ArgumentList.GetString(0);
Result := True;
end;
end;
Be careful, while debuging, placing a breakpoint in rendering process never work. It will never reached there.

Related

Detecting changes in an editable TWebBrowser

I'm loading an HTML local file into TWebBrowser as follows:
procedure TForm1.FormCreate(Sender: TObject);
begin
WebBrowser1.Navigate('file:///C:\Tmp\input.html');
end;
In the TWebBrowser.OnDocumentComplete event handler I'm making it editable:
procedure TForm1.WebBrowser1DocumentComplete(ASender: TObject;
const pDisp: IDispatch; const URL: OleVariant);
begin
(WebBrowser1.Document as IHTMLDocument2).designMode := 'on';
end;
I need to be notified as soon as the user applies any changes through the TWebBrowser (i.e: he writes something...) but I can't see any OnChanged or similar event handler.
I've tried capturing WM_PASTE and WM_KEYDOWN but my code is never executed:
TMyWebBrowser = class(TWebBrowser)
public
procedure WM_Paste(var Message: TWMPaste); message WM_PASTE;
procedure WM_KeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
end;
...
procedure TMyWebBrowser.WM_Paste(var Message: TWMPaste);
begin
inherited;
ShowMessage('Paste');
end;
procedure TMyWebBrowser.WM_KEYDOWN(var Message: TWMKeyDown);
begin
inherited;
ShowMessage('KeyDown');
end;
I've also tried setting the WindowProc property but without any success.
To capture changes to the document in design mode you should use its IMarkupContainer2 interface to register an IHTMLChangeSink via RegisterForDirtyRange method. The process is pretty simple - implement IHTMLChangeSink, obtain IMarkupContainer2 from WebBrowser1.Document and call its RegisterForDirtyRange method, but there's a catch.
When you change the designMode of IHTMLDocument2, TWebBrowser control reloads the current document and it loses all registered change sinks. Therefore you should register it after putting the document in design mode. After that you receive change notifications via IHTMLChangeSink.Notify method.
But there's another catch. Since entering the design mode causes reloading of the document and that in turn causes changing the readyState property of the document to 'loading' and then consecutively to 'complete'. Your change sink will receive those readyState change notifications. Note that TWebBrowser.OnDocumentComplete is not invoked after entering design mode. That's why you should ignore any notifications until the document is fully reloaded in design mode.
Another minor complication is that RegisterForDirtyRange creates a cookie that you need to maintain in order to unregister the change sink. Since you need a class to implement IHTMLChangeSink anyway, it could also encapsulate the design mode state and change registration.
uses
System.SysUtils, SHDocVw, MSHTML;
const
DesignMode: array[Boolean] of string = ('off', 'on');
type
TWebBrowserDesign = class(TInterfacedObject, IHTMLChangeSink)
private
FDirtyRangeCookie: LongWord;
FDocumentComplete: Boolean;
FHTMLDocument2: IHTMLDocument2;
FMarkupContainer2: IMarkupContainer2;
FOnChange: TProc;
{ IHTMLChangeSink }
function Notify: HResult; stdcall;
public
constructor Create(WebBrowser: TWebBrowser; const AOnChange: TProc);
destructor Destroy; override;
end;
constructor TWebBrowserDesign.Create(WebBrowser: TWebBrowser; const AOnChange: TProc);
begin
inherited Create;
if not Assigned(WebBrowser) then
raise Exception.Create('Web browser control missing.');
if not Supports(WebBrowser.Document, IHTMLDocument2, FHTMLDocument2) then
raise Exception.Create('No HTML document loaded.');
FHTMLDocument2.designMode := DesignMode[True];
if Supports(WebBrowser.Document, IMarkupContainer2, FMarkupContainer2) then
begin
if FMarkupContainer2.RegisterForDirtyRange(Self, FDirtyRangeCookie) <> S_OK then
FDirtyRangeCookie := 0
else
_Release;
end;
FOnChange := AOnChange;
end;
destructor TWebBrowserDesign.Destroy;
begin
if Assigned(FMarkupContainer2) and (FDirtyRangeCookie <> 0) then
FMarkupContainer2.UnRegisterForDirtyRange(FDirtyRangeCookie);
if Assigned(FHTMLDocument2) then
FHTMLDocument2.designMode := DesignMode[False];
inherited;
end;
function TWebBrowserDesign.Notify: HResult;
begin
Result := S_OK;
if not FDocumentComplete then
FDocumentComplete := FHTMLDocument2.readyState = 'complete'
else if Assigned(FOnChange) then
FOnChange();
end;
Note the call to _Release after registering the change sink. This is to "prevent" markup container from holding strong reference to TWebBrowserDesign instance. That allows you to control design mode using the lifetime of TWebBrowserDesign instance:
type
TForm1 = class(TForm)
{ ... }
private
FWebBrowserDesign: IInterface;
{ ... }
end;
procedure TForm1.WebBrowser1DocumentComplete(ASender: TObject;
const pDisp: IDispatch; const URL: OleVariant);
begin
{ enter design mode }
FWebBrowserDesign := TWebBrowserDesign.Create(WebBrowser1, procedure
begin
ButtonSave.Enabled := True;
end);
end;
procedure TForm1.ButtonSave(Sender: TObject);
begin
{ exit design mode }
FWebBrowserDesign := nil;
ButtonSave.Enabled := False;
end;
Alternatively you can implement change sink as a component.
type
TWebBrowserDesign = class(TComponent, IHTMLChangeSink)
private
FDirtyRangeCookie: LongWord;
FDocumentComplete: Boolean;
FHTMLDocument2: IHTMLDocument2;
FMarkupContainer2: IMarkupContainer2;
FOnChange: TNotifyEvent;
FWebBrowser: TWebBrowser;
procedure EnterDesignMode;
procedure ExitDesignMode;
function GetActive: Boolean;
procedure SetActive(const Value: Boolean);
procedure SetWebBrowser(const Value: TWebBrowser);
{ IHTMLChangeSink }
function Notify: HResult; stdcall;
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
destructor Destroy; override;
published
property Active: Boolean read GetActive write SetActive;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property WebBrowser: TWebBrowser read FWebBrowser write SetWebBrowser;
end;
destructor TWebBrowserDesign.Destroy;
begin
ExitDesignMode;
inherited;
end;
procedure TWebBrowserDesign.EnterDesignMode;
begin
if not Assigned(FWebBrowser) then
raise Exception.Create('Web browser control missing.');
if not Supports(FWebBrowser.Document, IHTMLDocument2, FHTMLDocument2) then
raise Exception.Create('No HTML document loaded.');
try
FHTMLDocument2.designMode := DesignMode[True];
if Supports(FWebBrowser.Document, IMarkupContainer2, FMarkupContainer2) then
begin
if FMarkupContainer2.RegisterForDirtyRange(Self, FDirtyRangeCookie) <> S_OK then
FDirtyRangeCookie := 0;
end;
except
ExitDesignMode;
raise;
end;
end;
procedure TWebBrowserDesign.ExitDesignMode;
begin
if Assigned(FMarkupContainer2) then
begin
if FDirtyRangeCookie <> 0 then
begin
FMarkupContainer2.UnRegisterForDirtyRange(FDirtyRangeCookie);
FDirtyRangeCookie := 0;
end;
FMarkupContainer2 := nil;
end;
if Assigned(FHTMLDocument2) then
begin
FHTMLDocument2.designMode := DesignMode[False];
if not (csDestroying in ComponentState) then
FHTMLDocument2 := nil; { causes AV when its hosting TWebBrowser component is destroying; I didn't dig into details }
end;
FDocumentComplete := False;
end;
function TWebBrowserDesign.GetActive: Boolean;
begin
Result := Assigned(FHTMLDocument2);
end;
procedure TWebBrowserDesign.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if (Operation = opRemove) and (AComponent = FWebBrowser) then
WebBrowser := nil;
end;
function TWebBrowserDesign.Notify: HResult;
begin
Result := S_OK;
if not FDocumentComplete then
FDocumentComplete := FHTMLDocument2.readyState = 'complete'
else if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure TWebBrowserDesign.SetActive(const Value: Boolean);
begin
if Active <> Value then
begin
if Value then
EnterDesignMode
else
ExitDesignMode;
end;
end;
procedure TWebBrowserDesign.SetWebBrowser(const Value: TWebBrowser);
begin
if Assigned(FWebBrowser) then
begin
ExitDesignMode;
FWebBrowser.RemoveFreeNotification(Self);
end;
FWebBrowser := Value;
if Assigned(FWebBrowser) then
FWebBrowser.FreeNotification(Self);
end;
If you put such a component in a design-time package and register it within the IDE, then you'll be able to link this component with TWebBrowser and assign OnChange event handler in the form designer. Use Active property in code to enter/exit the design mode.
type
TForm1 = class(TForm)
{ ... }
WebBrowserDesign1: TWebBrowserDesign;
{ ... }
end;
procedure WebBrowserDesign1Change(Sender: TObject);
begin
ButtonSave.Enabled := True;
end;
procedure TForm1.WebBrowser1DocumentComplete(ASender: TObject;
const pDisp: IDispatch; const URL: OleVariant);
begin
{ enter design mode }
WebBrowserDesign1.Active := True;
end;
procedure TForm1.ButtonSave(Sender: TObject);
begin
{ exit design mode }
WebBrowserDesign1.Active := False;
ButtonSave.Enabled := False;
end;
NB: Similar question has been asked regarding C#/WinForms - How do I detect when the content of a WebBrowser control has changed (in design mode)?
Final note: I'm not convinced that enabling save button after a change is the best UX design. If you think that the code above is worth to achieve your goal then go ahead. This is just a proof of concept and the code hasn't been thoroughly tested. Use it at your own risk.

Client/Server application

I am writing a client / server application. There is one server and several clients.
When connecting a client, the task is to add its IP address to the ListBox, and when disconnecting the client, remove it from the ListBox. Then exchange messages between the client and server.
Three questions arose: when a client connects, its IP address is added to the ListBox, but when disconnected, it is not deleted from there, here is the code:
type
TSimpleClient = class(TObject)
DNS,
Name : String;
ListLink : Integer;
Thread : Pointer;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient.Create;
Client.DNS := AContext.Connection.Socket.Binding.PeerIP;
Client.ListLink := ListBox1.Items.Count;
Client.Thread := AContext;
ListBox1.Items.Add(Client.DNS);
AContext.Data := Client;
Clients.Add(Client);
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
sleep(2000);
Client :=Pointer (AContext.Data);
Clients.Delete(Client.ListLink);
ListBox1.Items.Delete(ListBox1.Items.IndexOf(Client.DNS));
Client.Free;
AContext.Data := nil;
end;
The second question, when exchanging messages, the letters in Cyrillic are given as "???", all Google went through it and it was not possible to find an error.
And the third question, on the client is a timer that listens to messages from the server, when the timer is turned on, the client application hangs tight, putting all this into the stream is the same trouble, the code:
if not IdTCPClient1.Connected then
Exit;
s := IdTCPClient1.Socket.ReadLn;
if s <> '' then
Label1.Text := s;
I see quite a few problems with your code.
On the server side, you need to get rid of the TSimpleClient.ListLink field. You are misusing it, causing bad behaviors in your code since you don't keep it updated as clients are added/removed. Think of what happens when you have 2 clients connected, where ListLink is 0 and 1 respectively, and then the 1st client disconnects. The ListLink for the 2nd client will become invalid since you don't decrement it from 1 to 0.
Also TIdTCPServer is a multi-threaded component, its events are fired in the context of worker threads, but your event handler code is not thread-safe. You MUST synchronize with the main UI thread when accessing UI controls from worker threads, and you MUST protect your Clients list from concurrent access across thread boundaries. In this case, you don't really need your own Clients list to begin with as TIdTCPServer has its own thread-safe Contexts list that you can use to access the connected clients.
You are also not handling Unicode at all. By default, Indy's default byte encoding for Unicode strings is US-ASCII, which is why you are getting ? for non-ASCII characters. You can use the IOHandler's DefStringEncoding property to set a different byte encoding, such as IndyTextEncoding_UTF8 (if you are using Delphi 2007 or earlier, you might need to also use the IOHandler's DefAnsiEncoding property to specify how your ANSI strings are converted to/from Unicode. By default, it is set to IndyTextEncoding_OSDefault).
Try something more like this:
type
TSimpleClient = class(TObject)
DNS,
Name : String;
Thread : Pointer;
OutgoingMsgs : TIdThreadSafeStringList;
HasOutgoingMsgs : Boolean;
constructor Create;
destructor Destroy; override;
procedure Queue(const Msg: string);
procedure FlushMsgs;
end;
constructor TSimpleClient.Create;
begin
inherited;
OutgoingMsgs := TIdThreadSafeStringList.Create;
end;
destructor TSimpleClient.Destroy;
begin
OutgoingMsgs.Free;
inherited;
end;
procedure TSimpleClient.Queue(const Msg: string);
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
List.Add(Msg);
HasOutgoingMsgs := True;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TSimpleClient.FlushMsgs;
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
while List.Count > 0 do
begin
TIdContext(Thread).Connection.IOHandler.WriteLn(List[0]);
List.Delete(0);
end;
HasOutgoingMsgs := False;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
PeerIP: string;
Client: TSimpleClient;
begin
PeerIP := AContext.Binding.PeerIP;
Client := TSimpleClient.Create;
Client.DNS := PeerIP;
Client.Thread := AContext;
AContext.Data := Client;
TThread.Queue(nil,
procedure
begin
ListBox1.Items.AddObject(PeerIP, Client);
end
);
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
try
TThread.Queue(nil,
procedure
var
Index: Integer;
begin
Index := ListBox1.Items.IndexOfObject(Client);
if Index <> -1 then
ListBox1.Items.Delete(Index);
end;
);
finally
{ The anonymous procedure being passed to TThread.Queue() above captures
the Client variable itself, not its value. On ARC platforms, we need to
prevent Free() setting the variable to nil before it can be passed to
IndexOfObject(), and also because IndexOfObject() expects a live object
anyway. ARC will free the object when the anonymous procedure exits. On
non-ARC platforms, it is OK to Free() the object here, the variable will
not change value, and IndexOfObject() does not need a live object... }
{$IFNDEF AUTOREFCOUNT}
Client.Free;
{$ENDIF}
AContext.Data := nil;
end;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
if Client.HasOutgoingMsgs then
Client.FlushMsgs
else
Sleep(100);
end;
procedure TForm1.SendMessageToClient(Client: TSimpleClient; const Msg: string);
var
List: TIdContextList;
begin
List := IdTCPServer1.Contexts.LockList;
try
if List.IndexOf(TIdContext(Client.Thread)) <> -1 then // still connected?
Client.Queue(Msg);
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
Msg: string;
Client: TSimpleClient;
begin
Index := ListBox1.ItemIndex;
if Index = -1 then Exit;
Msg := Edit1.Text;
if Msg = '' then Exit;
Client := TSimpleClient(ListBox1.Items.Objects[Index]);
SendMessageToClient(Client, Msg);
end;
Alternatively, you can derive TSimpleClient from TIdServerContext and get rid of the Thread field altogether:
type
TSimpleClient = class(TIdServerContext)
DNS,
Name : String;
OutgoingMsgs : TIdThreadSafeStringList;
HasOutgoingMsgs : Boolean;
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
procedure Queue(const Msg: string);
procedure FlushMsgs;
end;
constructor TSimpleClient.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited Create(AConnection, AYarn, AList);
OutgoingMsgs := TIdThreadSafeStringList.Create;
end;
destructor TSimpleClient.Destroy;
begin
OutgoingMsgs.Free;
inherited;
end;
procedure TSimpleClient.Queue(const Msg: string);
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
List.Add(Msg);
HasOutgoingMsgs := True;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TSimpleClient.FlushMsgs;
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
while List.Count > 0 do
begin
Self.Connection.IOHandler.WriteLn(List[0]);
List.Delete(0);
end;
HasOutgoingMsgs := False;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
IdTCPServer1.ContextClass := TSimpleClient;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
PeerIP: string;
Client: TSimpleClient;
begin
PeerIP := AContext.Binding.PeerIP;
Client := TSimpleClient(AContext);
Client.DNS := PeerIP;
TThread.Queue(nil,
procedure
begin
ListBox1.Items.AddObject(PeerIP, Client);
end
);
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
Client := TSimpleClient(AContext);
TThread.Queue(nil,
procedure
var
Index: Integer;
begin
Index := ListBox1.Items.IndexOfObject(Client);
if Index <> -1 then
ListBox1.Items.Delete(Index);
end;
);
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient(AContext);
if Client.HasOutgoingMsgs then
Client.FlushMsgs
else
Sleep(100);
end;
procedure TForm1.SendMessageToClient(Client: TSimpleClient; const Msg: string);
var
List: TIdContextList;
begin
List := IdTCPServer1.Contexts.LockList;
try
if List.IndexOf(TIdContext(Client)) <> -1 then // still connected?
Client.Queue(Msg);
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
Msg: string;
Client: TSimpleClient;
begin
Index := ListBox1.ItemIndex;
if Index = -1 then Exit;
Msg := Edit1.Text;
if Msg = '' then Exit;
Client := TSimpleClient(ListBox1.Items.Objects[Index]);
SendMessageToClient(Client, Msg);
end;
On the client side, you are reading from the socket in the main UI thread, but Indy uses blocking sockets, and so its reading methods will block the calling thread until the requested data arrives. DON'T block the main UI thread! Read only if there is actually something available to read, or else move the reading into a separate worker thread. For example:
IdTCPClient1.Connect;
IdTCPClient1.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
...
IdTCPClient1.Disconnect;
...
procedure TForm1.Timer1Timer(Sender: TObject);
var
s: string;
begin
if IdTCPClient1.Connected and (not IdTCPClient1.IOHandler.InputBufferIsEmpty) then
begin
s := IdTCPClient1.IOHandler.ReadLn;
if s <> '' then
Label1.Text := s;
end;
end;
Alternatively:
type
TReadingThread = class(TThread)
protected
procedure Execute; override;
end;
procedure TReadingThread.Execute;
var
s: String;
begin
while not Terminated do
begin
s := Form1.IdTCPClient1.IOHandler.ReadLn;
if s <> '' then
begin
TThread.Queue(nil,
procedure
begin
Form1.Label1.Text := s;
end
);
end;
end;
end;
...
var
ReadingThread: TReadingThread = nil;
...
IdTCPClient1.Connect;
IdTCPClient1.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
ReadingThread := TReadingThread.Create(False);
...
ReadingThread.Terminate;
try
IdTCPClient1.Disconnect;
finally
ReadingThread.WaitFor;
ReadingThread.Free;
end;
Thank you so much Remy, your answer really helped me sort out my problem. I targeted Windows and Android platforms. I fixed your code a little and it worked for me:
type
TSimpleClient = class(TObject)
DNS,
Name : String;
Thread : Pointer;
OutgoingMsgs : TIdThreadSafeStringList;
HasOutgoingMsgs : Boolean;
constructor Create;
destructor Destroy; override;
procedure Queue(const Msg: string);
procedure FlushMsgs;
end;
constructor TSimpleClient.Create;
begin
inherited;
OutgoingMsgs := TIdThreadSafeStringList.Create;
end;
destructor TSimpleClient.Destroy;
begin
OutgoingMsgs.Free;
inherited;
end;
procedure TSimpleClient.Queue(const Msg: string);
var
List: TStringList;
Client: TSimpleClient;
begin
List := OutgoingMsgs.Lock;
try
List.Add(Msg);
HasOutgoingMsgs := True;
Client.FlushMsgs;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TSimpleClient.FlushMsgs;
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
while List.Count > 0 do
begin
TIdContext(Thread).Connection.IOHandler.WriteLn(List[0]);
List.Delete(0);
end;
HasOutgoingMsgs := False;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
PeerIP: string;
Client: TSimpleClient;
begin
PeerIP := AContext.Binding.PeerIP;
Client := TSimpleClient.Create;
Client.DNS := PeerIP;
Client.Thread := AContext;
AContext.Data := Client;
TThread.Queue(nil,
procedure
begin
ListBox1.Items.AddObject(PeerIP, Client);
end
);
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
try
TThread.Queue(nil,
procedure
var
Index: Integer;
begin
Index := ListBox1.Items.IndexOfObject(Client);
if Index <> -1 then
ListBox1.Items.Delete(Index);
end;
);
finally
{ The anonymous procedure being passed to TThread.Queue() above captures
the Client variable itself, not its value. On ARC platforms, we need to
prevent Free() setting the variable to nil before it can be passed to
IndexOfObject(), and also because IndexOfObject() expects a live object
anyway. ARC will free the object when the anonymous procedure exits. On
non-ARC platforms, it is OK to Free() the object here, the variable will
not change value, and IndexOfObject() does not need a live object... }
{$IFNDEF AUTOREFCOUNT}
Client.Free;
{$ENDIF}
AContext.Data := nil;
end;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
if Client.HasOutgoingMsgs then
Client.FlushMsgs
else
Sleep(100);
end;
procedure TForm1.SendMessageToClient(Client: TSimpleClient; const Msg: string);
var
List: TIdContextList;
begin
List := IdTCPServer1.Contexts.LockList;
try
if List.IndexOf(TIdContext(Client.Thread)) <> -1 then // still connected?
Client.Queue(Msg);
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
Msg: string;
Client: TSimpleClient;
begin
Index := ListBox1.ItemIndex;
if Index = -1 then Exit;
Msg := Edit1.Text;
if Msg = '' then Exit;
Client := TSimpleClient(ListBox1.Items.Objects[Index]);
SendMessageToClient(Client, Msg);
end;
I added a call to the FlushMsgs method from the TSimpleClient.Queue procedure and messages started to be sent, the list of clients is updated every time clients are connected and disconnected, and the server stopped hanging. Thanks again Remy, you helped a lot to speed up the development, golden man.

Delphi Chromium - Iterate DOM

I'm trying to iterate the DOM using TChromium and because i use Delphi 2007 i can't use anonymous methods, so i created a class inherited of TCEFDomVisitorOwn. My code is as below, but for some reason the 'visit' procedure is never called, so nothings happens.
unit udomprinc;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ceflib, cefvcl;
type
TForm1 = class(TForm)
Chromium1: TChromium;
procedure FormCreate(Sender: TObject);
procedure Chromium1LoadEnd(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame;
httpStatusCode: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TElementVisitor = class(TCefDomVisitorOwn)
private
FTagName, FHtml: string;
protected
procedure visit(const document: ICefDomDocument); override;
public
constructor Create(const par1, par2: string); reintroduce;
end;
var
Form1: TForm1;
implementation
constructor TElementVisitor.Create(const par1, par2: string);
begin
inherited create;
FTagName := par1;
FHtml := par2;
end;
procedure TElementVisitor.visit(const document: ICefDomDocument);
procedure ProcessNode(ANode: ICefDomNode);
var
Node: ICefDomNode;
tagname, name, html, value : string;
begin
if Assigned(ANode) then
begin
Node := ANode.FirstChild;
while Assigned(Node) do
begin
name := Node.GetElementAttribute('name');
tagname := Node.GetElementAttribute('tagname');
html := Node.GetElementAttribute('outerhtml');
value := Node.GetElementAttribute('value');
ProcessNode(Node);
Node := Node.NextSibling;
end;
end;
end;
begin
// this never happens
ProcessNode(document.Body);
end;
{$R *.dfm}
procedure TForm1.Chromium1LoadEnd(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame;
httpStatusCode: Integer);
var visitor : TElementVisitor;
begin
visitor := TElementVisitor.Create('input','test');
chromium1.Browser.MainFrame.VisitDom(visitor);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
chromium1.load('www.google.com');
end;
end.
It's all about sending messages back and forth. Your code is missing a RenderProcessHandler, this allows the Renderer to receive messages.
In your DPR you should have code like this
if not CefLoadLibDefault then
Exit;
in your pas file
type
TNotifyVisitor = procedure(aNode: ICefDomNode; var aLevel: integer);// of object;
TAttributeType = (atNodeName, atName, atId, atClass, atLevel);
TElementNameVisitor = class(TCefDomVisitorOwn)
private
FName: string;
FAttributeName: string;
FOnFound: TNotifyVisitor;
FOnVisited: TNotifyVisitor;
function getAttributeName: string;
protected
procedure visit(const document: ICefDomDocument); override;
public
constructor Create(const AName: string); reintroduce;
property OnFound: TNotifyVisitor read FOnFound write FOnFound;
property OnVisited: TNotifyVisitor read FOnVisited write FOnVisited;
property AttributeName: string read getAttributeName write FAttributeName;
end;
TCustomRenderProcessHandler = class(TCefRenderProcessHandlerOwn)
protected
function OnProcessMessageReceived(const browser: ICefBrowser;
sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; override;
end;
implementation
var
_Browser: ICefBrowser;
{ TElementNameVisitor }
constructor TElementNameVisitor.Create(const AName: string);
begin
inherited Create;
FName := AName;
end;
function TElementNameVisitor.getAttributeName: string;
begin
if FAttributeName = '' then
Result := 'name'
else
Result := FAttributeName;
end;
procedure TElementNameVisitor.visit(const document: ICefDomDocument);
var
a_Level: integer;
a_message: iCefProcessMessage;
procedure ProcessNode(aNode: ICefDomNode; var aLevel: integer);
var
a_Node: ICefDomNode;
a_Name: string;
begin
if Assigned(aNode) then
begin
inc(aLevel);
a_Node := aNode.FirstChild;
while Assigned(a_Node) do
begin
if Assigned(FOnVisited) then
FOnVisited(a_Node, aLevel);
if Assigned(FOnFound) then
begin
a_Name := a_Node.GetElementAttribute(AttributeName);
if SameText(a_Name, FName) then
begin
// do what you need with the Node here
if Assigned(FOnFound) then
FOnFound(a_Node, aLevel);
end;
end;
ProcessNode(a_Node, aLevel);
a_Node := a_Node.NextSibling;
end;
end;
end;
begin
a_Level := 0;
ProcessNode(document.Body, a_Level);
a_message := TCefProcessMessageRef.New(cdomdataFin);
_Browser.SendProcessMessage(PID_BROWSER, a_message);
end;
You'll need to create a RenderProcessHandler:
initialization
CefRenderProcessHandler := TCustomRenderProcessHandler.Create;
To use it...You send a message to Renderer like this
function TformBrowser.HasBrowser: boolean;
begin
Result := Assigned(Chromium1.browser);
end;
procedure TformBrowser.Button1Click(Sender: TObject);
var
a_message: ICefProcessMessage;
a_list: ICefListValue;
a_How: string;
begin
if HasBrowser and FLoaded then
begin
FLoaded := False;
Case rgFindDomNodeBy.ItemIndex of
0: a_How := 'ByName';
1: a_How := 'ById';
2: a_How := 'ByClass';
3: a_How := 'ByAll';
end;
lbFrames.Items.Clear;
a_message := TCefProcessMessageRef.New(a_How);
a_list := a_message.ArgumentList;
a_list.SetString(0, edtAttribute.Text);
Chromium1.browser.SendProcessMessage(PID_RENDERER,a_message);
end;
end;
The RenderProcessHandler will get the message:
{ TCustomRenderProcessHandler }
procedure _ElementCB(aNode: ICefDomNode; var aLevel: integer);
var
a_message: ICefProcessMessage;
begin
a_message := TCefProcessMessageRef.New('domdata');
a_message.ArgumentList.SetString(Ord(atNodeName), aNode.Name);
a_message.ArgumentList.SetString(Ord(atName), aNode.GetElementAttribute('name'));
a_message.ArgumentList.SetString(Ord(atId), aNode.GetElementAttribute('id'));
a_message.ArgumentList.SetString(Ord(atClass), aNode.GetElementAttribute('class'));
a_message.ArgumentList.SetInt(Ord(atLevel), aLevel);
_Browser.SendProcessMessage(PID_BROWSER, a_message);
end;
function TCustomRenderProcessHandler.OnProcessMessageReceived(
const browser: ICefBrowser; sourceProcess: TCefProcessId;
const message: ICefProcessMessage): Boolean;
var
a_list: ICefListValue;
begin
_Browser := browser;
Result := False;
if SameText(message.Name, 'ByAll') then
begin
_ProcessElements(browser.MainFrame, _ElementCB);
Result := True;
end else
if SameText(message.Name, 'ByName') then
begin
a_list := message.ArgumentList;
_ProcessElementsByAttribute(browser.MainFrame, a_list.GetString(0),'name', _ElementCB);
Result := True;
end else
if SameText(message.Name, 'ById') then
begin
a_list := message.ArgumentList;
_ProcessElementsByAttribute(browser.MainFrame, a_list.GetString(0), 'id', _ElementCB);
Result := True;
end else
if SameText(message.Name, 'ByClass') then
begin
a_list := message.ArgumentList;
_ProcessElementsByAttribute(browser.MainFrame, a_list.GetString(0), 'class', _ElementCB);
Result := True;
end;
end;
The RenderProcessHandler creates the Visitor(TElementNameVisitor)
procedure _ProcessElementsByAttribute(const aFrame: ICefFrame; aName, aAttributeName: string; aVisitor: TNotifyVisitor);
var
a_Visitor: TElementNameVisitor;
begin
if Assigned(aFrame) then
begin
a_Visitor := TElementNameVisitor.Create(aName);
a_Visitor.AttributeName := aAttributeName;
a_Visitor.OnFound := aVisitor;
aFrame.VisitDom(a_Visitor);
end;
end;
procedure _ProcessElements(const aFrame: ICefFrame; aVisitor: TNotifyVisitor);
var
a_Visitor: TElementNameVisitor;
begin
if Assigned(aFrame) then
begin
a_Visitor := TElementNameVisitor.Create('');
a_Visitor.OnVisited := aVisitor;
aFrame.VisitDom(a_Visitor);
end;
end;
The Visitor (TElementNameVisitor)then sends a message back to TChromium and you can tie into it like:
procedure TformBrowser.Chromium1ProcessMessageReceived(Sender: TObject;
const browser: ICefBrowser; sourceProcess: TCefProcessId;
const message: ICefProcessMessage; out Result: Boolean);
var
a_List: ICefListValue;
begin
if SameText(message.Name, 'domdata') then
begin
a_List := message.ArgumentList;
lbFrames.Items.Add(a_List.GetString(Ord(atNodeName)));
lbFrames.Items.Add('Name: ' + a_List.GetString(Ord(atName)));
lbFrames.Items.Add('Id: ' + a_List.GetString(Ord(atId)));
lbFrames.Items.Add('Class: ' + a_List.GetString(Ord(atClass)));
lbFrames.Items.Add('Level: ' + IntToStr(a_List.GetInt(Ord(atLevel))));
lbFrames.Items.Add('------------------');
Result := True;
end else
if SameText(message.Name, cdomdataFin) then
begin
FLoaded := True;
end else
begin
lbFrames.Items.Add('Unhandled message: ' + message.Name);
inherited;
end;
end;
-----------edit-------------
After looking at this code...it can be improved...to be more thread friendly
Delete this
var
_Browser: ICefBrowser;
change this
TNotifyVisitor = procedure(aBrowser: ICefBrowser; aNode: ICefDomNode; var aLevel: integer);// of object;
add this to TElementNameVisitor
property Browser: ICefBrowser read getBrowser write FBrowser;
Change references in TElementNameVisitor to Browser also add this
function TElementNameVisitor.getBrowser: ICefBrowser;
begin
if not Assigned(FBrowser) then
Raise Exception.Create('Need to set the Browser property when creating TElementNameVisitor.');
Result := FBrowser;
end;
Change these
procedure _ProcessElementsByAttribute(const aBrowser: ICefBrowser; aName, aAttributeName: string; aVisitor: TNotifyVisitor);
var
a_Visitor: TElementNameVisitor;
begin
if Assigned(aBrowser) and Assigned(aBrowser.MainFrame) then
begin
a_Visitor := TElementNameVisitor.Create(aName);
a_Visitor.Browser := aBrowser;
a_Visitor.AttributeName := aAttributeName;
a_Visitor.OnFound := aVisitor;
aBrowser.MainFrame.VisitDom(a_Visitor);
end;
end;
procedure _ProcessElements(const aBrowser: ICefBrowser; aVisitor: TNotifyVisitor);
var
a_Visitor: TElementNameVisitor;
begin
if Assigned(aBrowser) and Assigned(aBrowser.MainFrame) then
begin
a_Visitor := TElementNameVisitor.Create('');
a_Visitor.Browser := aBrowser;
a_Visitor.OnVisited := aVisitor;
aBrowser.MainFrame.VisitDom(a_Visitor);
end;
end;
Also change these
procedure _ElementCB(aBrowser: ICefBrowser; aNode: ICefDomNode; var aLevel: integer);
var
a_message: ICefProcessMessage;
begin
a_message := TCefProcessMessageRef.New(cdomdata);
a_message.ArgumentList.SetString(Ord(atNodeName), aNode.Name);
a_message.ArgumentList.SetString(Ord(atName), aNode.GetElementAttribute('name'));
a_message.ArgumentList.SetString(Ord(atId), aNode.GetElementAttribute('id'));
a_message.ArgumentList.SetString(Ord(atClass), aNode.GetElementAttribute('class'));
a_message.ArgumentList.SetInt(Ord(atLevel), aLevel);
aBrowser.SendProcessMessage(PID_BROWSER, a_message);
end;
function TCustomRenderProcessHandler.OnProcessMessageReceived(
const browser: ICefBrowser; sourceProcess: TCefProcessId;
const message: ICefProcessMessage): Boolean;
var
a_list: ICefListValue;
begin
Result := False;
if SameText(message.Name, 'ByAll') then
begin
_ProcessElements(browser, _ElementCB);
Result := True;
end else
if SameText(message.Name, 'ByName') then
begin
a_list := message.ArgumentList;
_ProcessElementsByAttribute(browser, a_list.GetString(0),'name', _ElementCB);
Result := True;
end else
if SameText(message.Name, 'ById') then
begin
a_list := message.ArgumentList;
_ProcessElementsByAttribute(browser, a_list.GetString(0), 'id', _ElementCB);
Result := True;
end else
if SameText(message.Name, 'ByClass') then
begin
a_list := message.ArgumentList;
_ProcessElementsByAttribute(browser, a_list.GetString(0), 'class', _ElementCB);
Result := True;
end;
end;

Console App and SetWindowsHookEx

Trying to setup a SetWindowsHookEx(WH_KEYBOARD) from a console app. I'm doing this inside thread, because I tried to to use the TThread.WaitFor method to keep the application openned, while the thread is running.
Important code parts:
type
THookKeyboard = procedure; stdcall;
KeyloggerThread = class(TThread)
private
const
MESSAGE_CODE = WM_USER + $1000;
var
HookOn, HookOff: THookKeyboard;
MsgReceptor: ^Integer;
MemFile: THandle;
function InstallKeyLogger(const TempDir: String): bool;
procedure HookMessage(var MessageHandler: TMessage); message MESSAGE_CODE;
protected
constructor Create;
procedure Execute; override;
end;
var
KeylogThreadCtrl: KeyloggerThread;
function KeyloggerThread.InstallKeyLogger(const TempDir: String): bool;
var
DLLHandle: THandle;
begin
Result:= false;
if FileExists(TempDir + DLLName) = true then
begin
DLLHandle:= LoadLibrary(PChar(TempDir + DLLName));
if DLLHandle <> 0 then
begin
#HookOn:= GetProcAddress(DLLHandle, 'HookOn');
#HookOff:= GetProcAddress(DLLHandle, 'HookOff');
end;
if assigned(HookOn) and assigned(HookOff) then
begin
MemFile:= CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0,SizeOf(Integer), 'Win32KLCom');
if MemFile <> 0 then
begin
MessageBox(0, 'starting keylogger', 'hook', MB_OK);
MsgReceptor:= MapViewOfFile(MemFile,FILE_MAP_WRITE,0,0,0);
HookOn;
Result:= true;
end;
end;
end;
end;
procedure KeyloggerThread.HookMessage(var MessageHandler: TMessage);
begin
MessageBox(0, 'pressed something!', 'hook', MB_OK);
end;
constructor KeyloggerThread.Create;
begin
inherited Create(false);
end;
procedure KeyloggerThread.Execute;
begin
while not Terminated do
begin
if not assigned(HookOn) then
if InstallKeyLogger(ExtractFilePath(ParamStr(0))) = false then
Terminate;
end;
end;
begin
if ParamStr(1) = '-runkeylog' then
begin
MessageBox(0, 'going to install keylogger', 'hook', MB_OK);
KeylogThreadCtrl:= KeyloggerThread.Create;
KeylogThreadCtrl.WaitFor;
end
end;
I know the InstallKeyLogger function is going fine, because I get the messagebox 'starting keylogger'.
Once I press any key, windows start freezing and I need to finish the application. The DLL code is:
library KeyboardDLL;
uses
Windows,
Messages;
{$R *.res}
const
MESSAGE_CODE = WM_USER + $1000;
var
KeyboardHook: HHook;
MemFile: THandle;
MsgReceptor: ^Integer;
function HookCallBack( Code : Integer;
wParam : WPARAM;
lParam : LPARAM
) : LRESULT; stdcall;
begin
if code=HC_ACTION then
begin
MemFile:= OpenFileMapping(FILE_MAP_WRITE,False, 'Win32KLCom');
if MemFile<>0 then
begin
MsgReceptor:= MapViewOfFile(MemFile,FILE_MAP_WRITE,0,0,0);
PostMessage(MsgReceptor^,MESSAGE_CODE,wParam,lParam);
end;
end;
Result:= CallNextHookEx(KeyboardHook, Code, wParam, lParam)
end;
procedure HookOn; stdcall;
begin
KeyboardHook:= SetWindowsHookEx(WH_KEYBOARD, #HookCallBack, HInstance , 0);
end;
procedure HookOff; stdcall;
begin
UnmapViewOfFile(MsgReceptor);
CloseHandle(MemFile);
UnhookWindowsHookEx(KeyboardHook);
end;
exports
HookOn,
HookOff;
begin
end.
It looks like you ported your hosting code from a VCL application, because you have some assumptions that don't hold for stand-alone threads, like the one you have there:
procedure HookMessage(var MessageHandler: TMessage); message MESSAGE_CODE;
Message procedures like this one only work in the context of a VCL form or control.
You can only post messages (use PostMessage) to window handles, not memory mapped files (as you attempt with the MsgReceptor pointer).
If you want your thread to be able to process messages, you must create a window handle and the thread must have a message loop (GetMessage/DispatchMessage, or similar).

TChromium how to block middle mouse click on the links?

How to block middle mouse click on the links in TChromium?
I want to handle this middle mouse click by my own to open it in new tab, so i need to block this middle mouse click in TChromium, and then hook middle mouse, and then open selected link in new tab.
I have this default function:
function TCustomRenderProcessHandler.OnBeforeNavigation(const browser: ICefBrowser;
const frame: ICefFrame; const request: ICefRequest;
navigationType: TCefNavigationType; isRedirect: Boolean): Boolean;
begin
Result:=False;
end;
But exactly it gives nothing.
TNX
I did it by some another way.
#TLama, thanks for fast working Hook Function.
So, how i did it:
//#HOOK PROC
function MouseProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
HookStruct: TMouseHookStruct;
begin
HookStruct := PMouseHookStruct(lParam)^;
if (nCode >= 0) then
begin
case wParam of
WM_MBUTTONDOWN:
Begin
MiddleDown := True;
LeftMouse := False;
End;
WM_LBUTTONDOWN:
Begin
MiddleDown := False;
LeftMouse := True;
End;
WM_RBUTTONDOWN:
Begin
MiddleDown := False;
LeftMouse := False;
End;
end;
end;
Result := CallNextHookEx(0, nCode, wParam, lParam);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
If(MiddleDown) then
Begin
MiddleDown:=False;
If(SelectedItem<>'') Then
Form1.AddNewTab(SelectedItem,SelectedItem,'');
End
Else If(LeftMouse) then
Begin
LeftMouse:=False;
If(SelectedItem<>'') Then
FBrowsers[Current_FBrowser_Index].Load(SelectedItem);
End;
end;
function TCustomRenderProcessHandler.OnBeforeNavigation(const browser: ICefBrowser;
const frame: ICefFrame; const request: ICefRequest;
navigationType: TCefNavigationType; isRedirect: Boolean): Boolean;
begin
if navigationType = NAVIGATION_LINK_CLICKED then
begin
Result := True;
end
else
Result := False;
end;
So, thats how it works in my DCEF3 :)
Thanks to all for help!!!

Resources