mirror of
https://github.com/salvadordf/CEF4Delphi.git
synced 2025-04-17 06:57:13 +02:00
Added the ConsoleBrowser demo for Linux
This commit is contained in:
Salvador Díaz Fau
parent
efad8d654b
commit
0c117497c3
2
demos/Lazarus_Linux_Console/ConsoleBrowser/00-Delete.bat
Normal file
2
demos/Lazarus_Linux_Console/ConsoleBrowser/00-Delete.bat
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
rmdir /S /Q lib
|
||||||
|
rmdir /S /Q backup
|
||||||
@ -0,0 +1,93 @@
|
|||||||
|
<?xml version="1.0" encoding="UTF-8"?>
|
||||||
|
<CONFIG>
|
||||||
|
<ProjectOptions>
|
||||||
|
<Version Value="12"/>
|
||||||
|
<General>
|
||||||
|
<Flags>
|
||||||
|
<MainUnitHasCreateFormStatements Value="False"/>
|
||||||
|
<MainUnitHasTitleStatement Value="False"/>
|
||||||
|
<MainUnitHasScaledStatement Value="False"/>
|
||||||
|
</Flags>
|
||||||
|
<SessionStorage Value="InProjectDir"/>
|
||||||
|
<Title Value="ConsoleBrowser"/>
|
||||||
|
<UseAppBundle Value="False"/>
|
||||||
|
<ResourceType Value="res"/>
|
||||||
|
</General>
|
||||||
|
<MacroValues Count="1">
|
||||||
|
<Macro2 Name="LCLWidgetType" Value="gtk3"/>
|
||||||
|
</MacroValues>
|
||||||
|
<BuildModes>
|
||||||
|
<Item Name="Default" Default="True"/>
|
||||||
|
<SharedMatrixOptions Count="2">
|
||||||
|
<Item1 ID="459818913724"/>
|
||||||
|
<Item2 ID="286517618039" Modes="Default" Type="IDEMacro" MacroName="LCLWidgetType" Value="gtk3"/>
|
||||||
|
</SharedMatrixOptions>
|
||||||
|
</BuildModes>
|
||||||
|
<PublishOptions>
|
||||||
|
<Version Value="2"/>
|
||||||
|
<UseFileFilters Value="True"/>
|
||||||
|
</PublishOptions>
|
||||||
|
<RunParams>
|
||||||
|
<FormatVersion Value="2"/>
|
||||||
|
</RunParams>
|
||||||
|
<RequiredPackages>
|
||||||
|
<Item>
|
||||||
|
<PackageName Value="CEF4Delphi_Lazarus"/>
|
||||||
|
</Item>
|
||||||
|
</RequiredPackages>
|
||||||
|
<Units>
|
||||||
|
<Unit>
|
||||||
|
<Filename Value="consolebrowser.lpr"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
</Unit>
|
||||||
|
<Unit>
|
||||||
|
<Filename Value="ucustommessage.pas"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
</Unit>
|
||||||
|
<Unit>
|
||||||
|
<Filename Value="uencapsulatedbrowser.pas"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
</Unit>
|
||||||
|
<Unit>
|
||||||
|
<Filename Value="uworkerthread.pas"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
</Unit>
|
||||||
|
<Unit>
|
||||||
|
<Filename Value="ucefbrowserthread.pas"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
</Unit>
|
||||||
|
<Unit>
|
||||||
|
<Filename Value="interfaces.pas"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
</Unit>
|
||||||
|
</Units>
|
||||||
|
</ProjectOptions>
|
||||||
|
<CompilerOptions>
|
||||||
|
<Version Value="11"/>
|
||||||
|
<Target>
|
||||||
|
<Filename Value="../../../bin/consolebrowser"/>
|
||||||
|
</Target>
|
||||||
|
<SearchPaths>
|
||||||
|
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||||
|
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
|
||||||
|
</SearchPaths>
|
||||||
|
<Linking>
|
||||||
|
<Debugging>
|
||||||
|
<DebugInfoType Value="dsDwarf3"/>
|
||||||
|
</Debugging>
|
||||||
|
</Linking>
|
||||||
|
</CompilerOptions>
|
||||||
|
<Debugging>
|
||||||
|
<Exceptions>
|
||||||
|
<Item>
|
||||||
|
<Name Value="EAbort"/>
|
||||||
|
</Item>
|
||||||
|
<Item>
|
||||||
|
<Name Value="ECodetoolError"/>
|
||||||
|
</Item>
|
||||||
|
<Item>
|
||||||
|
<Name Value="EFOpenError"/>
|
||||||
|
</Item>
|
||||||
|
</Exceptions>
|
||||||
|
</Debugging>
|
||||||
|
</CONFIG>
|
||||||
@ -0,0 +1,33 @@
|
|||||||
|
program consolebrowser;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF UNIX}
|
||||||
|
cthreads,
|
||||||
|
{$ENDIF}
|
||||||
|
// "Interfaces" is a custom unit used to initialize the LCL WidgetSet
|
||||||
|
// We keep the same name to avoid a Lazarus warning.
|
||||||
|
Interfaces, // this includes the LCL widgetset
|
||||||
|
Classes, SysUtils, uCEFApplication, uencapsulatedbrowser;
|
||||||
|
|
||||||
|
begin
|
||||||
|
try
|
||||||
|
try
|
||||||
|
CreateGlobalCEFApp;
|
||||||
|
|
||||||
|
// The LCL Widgetset must be initialized after the CEF initialization
|
||||||
|
CustomWidgetSetInitialization;
|
||||||
|
|
||||||
|
if WaitForMainAppEvent then
|
||||||
|
WriteResult;
|
||||||
|
except
|
||||||
|
on E: Exception do
|
||||||
|
Writeln(E.ClassName, ': ', E.Message);
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
CustomWidgetSetFinalization;
|
||||||
|
DestroyGlobalCEFApp;
|
||||||
|
end;
|
||||||
|
end.
|
||||||
|
|
||||||
@ -0,0 +1,66 @@
|
|||||||
|
<?xml version="1.0" encoding="UTF-8"?>
|
||||||
|
<CONFIG>
|
||||||
|
<ProjectOptions>
|
||||||
|
<Version Value="12"/>
|
||||||
|
<General>
|
||||||
|
<Flags>
|
||||||
|
<MainUnitHasCreateFormStatements Value="False"/>
|
||||||
|
<MainUnitHasTitleStatement Value="False"/>
|
||||||
|
<MainUnitHasScaledStatement Value="False"/>
|
||||||
|
</Flags>
|
||||||
|
<SessionStorage Value="InProjectDir"/>
|
||||||
|
<Title Value="ConsoleBrowser"/>
|
||||||
|
<UseAppBundle Value="False"/>
|
||||||
|
<ResourceType Value="res"/>
|
||||||
|
</General>
|
||||||
|
<BuildModes>
|
||||||
|
<Item Name="Default" Default="True"/>
|
||||||
|
</BuildModes>
|
||||||
|
<PublishOptions>
|
||||||
|
<Version Value="2"/>
|
||||||
|
<UseFileFilters Value="True"/>
|
||||||
|
</PublishOptions>
|
||||||
|
<RunParams>
|
||||||
|
<FormatVersion Value="2"/>
|
||||||
|
</RunParams>
|
||||||
|
<RequiredPackages>
|
||||||
|
<Item>
|
||||||
|
<PackageName Value="CEF4Delphi_Lazarus"/>
|
||||||
|
</Item>
|
||||||
|
</RequiredPackages>
|
||||||
|
<Units>
|
||||||
|
<Unit>
|
||||||
|
<Filename Value="consolebrowser_sp.lpr"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
</Unit>
|
||||||
|
</Units>
|
||||||
|
</ProjectOptions>
|
||||||
|
<CompilerOptions>
|
||||||
|
<Version Value="11"/>
|
||||||
|
<Target>
|
||||||
|
<Filename Value="../../../bin/consolebrowser_sp"/>
|
||||||
|
</Target>
|
||||||
|
<SearchPaths>
|
||||||
|
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||||
|
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
|
||||||
|
</SearchPaths>
|
||||||
|
<Linking>
|
||||||
|
<Debugging>
|
||||||
|
<DebugInfoType Value="dsDwarf3"/>
|
||||||
|
</Debugging>
|
||||||
|
</Linking>
|
||||||
|
</CompilerOptions>
|
||||||
|
<Debugging>
|
||||||
|
<Exceptions>
|
||||||
|
<Item>
|
||||||
|
<Name Value="EAbort"/>
|
||||||
|
</Item>
|
||||||
|
<Item>
|
||||||
|
<Name Value="ECodetoolError"/>
|
||||||
|
</Item>
|
||||||
|
<Item>
|
||||||
|
<Name Value="EFOpenError"/>
|
||||||
|
</Item>
|
||||||
|
</Exceptions>
|
||||||
|
</Debugging>
|
||||||
|
</CONFIG>
|
||||||
@ -0,0 +1,20 @@
|
|||||||
|
program consolebrowser_sp;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF UNIX}
|
||||||
|
cthreads,
|
||||||
|
{$ENDIF}
|
||||||
|
Classes, SysUtils, uCEFApplicationCore;
|
||||||
|
|
||||||
|
begin
|
||||||
|
GlobalCEFApp := TCefApplicationCore.Create;
|
||||||
|
GlobalCEFApp.WindowlessRenderingEnabled := True;
|
||||||
|
GlobalCEFApp.ShowMessageDlg := False;
|
||||||
|
GlobalCEFApp.BlinkSettings := 'hideScrollbars';
|
||||||
|
GlobalCEFApp.SetCurrentDir := True;
|
||||||
|
GlobalCEFApp.StartSubProcess;
|
||||||
|
DestroyGlobalCEFApp;
|
||||||
|
end.
|
||||||
|
|
||||||
68
demos/Lazarus_Linux_Console/ConsoleBrowser/interfaces.pas
Normal file
68
demos/Lazarus_Linux_Console/ConsoleBrowser/interfaces.pas
Normal file
@ -0,0 +1,68 @@
|
|||||||
|
{
|
||||||
|
/***************************************************************************
|
||||||
|
Interfaces.pp - determines what interface to use
|
||||||
|
-------------------
|
||||||
|
|
||||||
|
Initial Revision : Thu July 1st CST 1999
|
||||||
|
|
||||||
|
|
||||||
|
***************************************************************************/
|
||||||
|
|
||||||
|
*****************************************************************************
|
||||||
|
This file is part of the Lazarus Component Library (LCL)
|
||||||
|
|
||||||
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
||||||
|
for details about the license.
|
||||||
|
*****************************************************************************
|
||||||
|
}
|
||||||
|
|
||||||
|
unit interfaces;
|
||||||
|
|
||||||
|
{$mode objfpc}
|
||||||
|
{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF UNIX}{$IFNDEF DisableCWString}cwstring,{$ENDIF}{$ENDIF}
|
||||||
|
InterfaceBase;
|
||||||
|
|
||||||
|
procedure CustomWidgetSetInitialization;
|
||||||
|
procedure CustomWidgetSetFinalization;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
gtk3int, Forms, xlib,
|
||||||
|
uCEFLinuxFunctions;
|
||||||
|
|
||||||
|
function CustomX11ErrorHandler(Display:PDisplay; ErrorEv:PXErrorEvent):longint;cdecl;
|
||||||
|
begin
|
||||||
|
{$IFDEF DEBUG}
|
||||||
|
XError := ErrorEv^.error_code;
|
||||||
|
WriteLn('Error: ' + IntToStr(XError));
|
||||||
|
{$ENDIF}
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CustomXIOErrorHandler(Display:PDisplay):longint;cdecl;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure CustomWidgetSetInitialization;
|
||||||
|
begin
|
||||||
|
//gdk_set_allowed_backends('X11');
|
||||||
|
CreateWidgetset(TGtk3WidgetSet);
|
||||||
|
// Install xlib error handlers so that the application won't be terminated
|
||||||
|
// on non-fatal errors. Must be done after initializing GTK.
|
||||||
|
XSetErrorHandler(@CustomX11ErrorHandler);
|
||||||
|
XSetIOErrorHandler(@CustomXIOErrorHandler);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure CustomWidgetSetFinalization;
|
||||||
|
begin
|
||||||
|
FreeWidgetSet;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
443
demos/Lazarus_Linux_Console/ConsoleBrowser/ucefbrowserthread.pas
Normal file
443
demos/Lazarus_Linux_Console/ConsoleBrowser/ucefbrowserthread.pas
Normal file
@ -0,0 +1,443 @@
|
|||||||
|
unit ucefbrowserthread;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, SyncObjs,
|
||||||
|
uworkerthread, ucustommessage,
|
||||||
|
uCEFChromium, uCEFTypes, uCEFInterfaces, uCEFConstants, uCEFBufferPanel,
|
||||||
|
uCEFChromiumCore, uCEFMiscFunctions;
|
||||||
|
|
||||||
|
type
|
||||||
|
TThreadStatus = (tsInitializing, tsIdle, tsLoading, tsClosing, tsDestroyed, tsInitError);
|
||||||
|
|
||||||
|
TSize = record
|
||||||
|
cx : integer;
|
||||||
|
cy : integer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TCEFBrowserThread = class(TWorkerThread)
|
||||||
|
protected
|
||||||
|
FBrowser : TChromium;
|
||||||
|
FStatus : TThreadStatus;
|
||||||
|
FBrowserSize : TSize;
|
||||||
|
FBrowserCS : TCriticalSection;
|
||||||
|
FErrorCode : integer;
|
||||||
|
FErrorText : string;
|
||||||
|
FFailedURL : string;
|
||||||
|
FDefaultURL : string;
|
||||||
|
FFileName : string;
|
||||||
|
FMessageID : integer;
|
||||||
|
FOnInitialized : TNotifyEvent;
|
||||||
|
FOnSnapshotAvailable : TNotifyEvent;
|
||||||
|
FOnError : TNotifyEvent;
|
||||||
|
|
||||||
|
function GetErrorCode : integer;
|
||||||
|
function GetErrorText : string;
|
||||||
|
function GetFailedURL : string;
|
||||||
|
function GetInitialized : boolean;
|
||||||
|
function GetClosing : boolean;
|
||||||
|
function GetStatus : TThreadStatus;
|
||||||
|
function GetFileName : string;
|
||||||
|
|
||||||
|
procedure SetErrorText(const aValue : string);
|
||||||
|
procedure SetFileName(const aValue : string);
|
||||||
|
procedure SetStatus(aValue : TThreadStatus);
|
||||||
|
|
||||||
|
procedure Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
|
||||||
|
procedure Browser_OnGetViewRect(Sender: TObject; const browser: ICefBrowser; var rect: TCefRect);
|
||||||
|
procedure Browser_OnGetScreenInfo(Sender: TObject; const browser: ICefBrowser; var screenInfo: TCefScreenInfo; out Result: Boolean);
|
||||||
|
procedure Browser_OnBeforePopup(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; const targetUrl, targetFrameName: ustring; targetDisposition: TCefWindowOpenDisposition; userGesture: Boolean; const popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; var client: ICefClient; var settings: TCefBrowserSettings; var extra_info: ICefDictionaryValue; var noJavascriptAccess: Boolean; var Result: Boolean);
|
||||||
|
procedure Browser_OnBeforeClose(Sender: TObject; const browser: ICefBrowser);
|
||||||
|
procedure Browser_OnLoadError(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; const errorText, failedUrl: ustring);
|
||||||
|
procedure Browser_OnLoadingStateChange(Sender: TObject; const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean);
|
||||||
|
procedure Browser_OnDevToolsMethodResult(Sender: TObject; const browser: ICefBrowser; message_id: Integer; success: Boolean; const result: ICefValue);
|
||||||
|
procedure Browser_OnOpenUrlFromTab(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; const targetUrl: ustring; targetDisposition: TCefWindowOpenDisposition; userGesture: Boolean; out Result: Boolean);
|
||||||
|
|
||||||
|
procedure DoOnInitialized;
|
||||||
|
procedure DoOnError;
|
||||||
|
procedure DoOnSnapshotAvailable;
|
||||||
|
|
||||||
|
procedure ProcessValue(const aInfo : TMsgInfo); override;
|
||||||
|
procedure DoLoadURL(const aURL : string);
|
||||||
|
function CreateBrowser : boolean;
|
||||||
|
procedure CloseBrowser;
|
||||||
|
procedure InitError;
|
||||||
|
procedure Execute; override;
|
||||||
|
|
||||||
|
public
|
||||||
|
constructor Create(aWidth, aHeight : integer; const aDefaultURL, aFileName : string);
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure AfterConstruction; override;
|
||||||
|
procedure TerminateBrowserThread;
|
||||||
|
procedure LoadURL(const aURL : string);
|
||||||
|
|
||||||
|
property ErrorCode : integer read GetErrorCode;
|
||||||
|
property ErrorText : string read GetErrorText write SetErrorText;
|
||||||
|
property FailedUrl : string read GetFailedUrl;
|
||||||
|
property Initialized : boolean read GetInitialized;
|
||||||
|
property Closing : boolean read GetClosing;
|
||||||
|
property Status : TThreadStatus read GetStatus write SetStatus;
|
||||||
|
property FileName : string read GetFileName write SetFileName;
|
||||||
|
|
||||||
|
property OnInitialized : TNotifyEvent read FOnInitialized write FOnInitialized;
|
||||||
|
property OnSnapshotAvailable : TNotifyEvent read FOnSnapshotAvailable write FOnSnapshotAvailable;
|
||||||
|
property OnError : TNotifyEvent read FOnError write FOnError;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
uCEFDictionaryValue, uCEFJson;
|
||||||
|
|
||||||
|
const
|
||||||
|
WORKERTHREADMSG_LOADURL = WORKERTHREADMSG_QUIT + 1;
|
||||||
|
WORKERTHREADMSG_DOONERROR = WORKERTHREADMSG_QUIT + 2;
|
||||||
|
WORKERTHREADMSG_CLOSEBROWSER = WORKERTHREADMSG_QUIT + 3;
|
||||||
|
|
||||||
|
constructor TCEFBrowserThread.Create(aWidth, aHeight : integer; const aDefaultURL, aFileName : string);
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
|
||||||
|
FStatus := tsInitializing;
|
||||||
|
FBrowser := nil;
|
||||||
|
FBrowserSize.cx := aWidth;
|
||||||
|
FBrowserSize.cy := aHeight;
|
||||||
|
FDefaultURL := aDefaultURL;
|
||||||
|
FFileName := aFileName;
|
||||||
|
FBrowserCS := nil;
|
||||||
|
FMessageID := -1;
|
||||||
|
FOnInitialized := nil;
|
||||||
|
FOnSnapshotAvailable := nil;
|
||||||
|
FOnError := nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TCEFBrowserThread.Destroy;
|
||||||
|
begin
|
||||||
|
if (FBrowser <> nil) then
|
||||||
|
FreeAndNil(FBrowser);
|
||||||
|
|
||||||
|
if (FBrowserCS <> nil) then
|
||||||
|
FreeAndNil(FBrowserCS);
|
||||||
|
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.AfterConstruction;
|
||||||
|
begin
|
||||||
|
inherited AfterConstruction;
|
||||||
|
|
||||||
|
FBrowserCS := TCriticalSection.Create;
|
||||||
|
|
||||||
|
FBrowser := TChromium.Create(nil);
|
||||||
|
FBrowser.DefaultURL := FDefaultURL;
|
||||||
|
FBrowser.Options.BackgroundColor := CefColorSetARGB($FF, $FF, $FF, $FF);
|
||||||
|
FBrowser.OnAfterCreated := @Browser_OnAfterCreated;
|
||||||
|
FBrowser.OnGetViewRect := @Browser_OnGetViewRect;
|
||||||
|
FBrowser.OnGetScreenInfo := @Browser_OnGetScreenInfo;
|
||||||
|
FBrowser.OnBeforePopup := @Browser_OnBeforePopup;
|
||||||
|
FBrowser.OnBeforeClose := @Browser_OnBeforeClose;
|
||||||
|
FBrowser.OnLoadError := @Browser_OnLoadError;
|
||||||
|
FBrowser.OnLoadingStateChange := @Browser_OnLoadingStateChange;
|
||||||
|
FBrowser.OnOpenUrlFromTab := @Browser_OnOpenUrlFromTab;
|
||||||
|
FBrowser.OnDevToolsMethodResult := @Browser_OnDevToolsMethodResult;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.TerminateBrowserThread;
|
||||||
|
begin
|
||||||
|
Terminate;
|
||||||
|
EnqueueMessage(WORKERTHREADMSG_CLOSEBROWSER);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.LoadURL(const aURL : string);
|
||||||
|
begin
|
||||||
|
EnqueueMessage(WORKERTHREADMSG_LOADURL, 0, aURL);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetErrorCode : integer;
|
||||||
|
begin
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
Result := FErrorCode;
|
||||||
|
FBrowserCS.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetErrorText : string;
|
||||||
|
begin
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
Result := FErrorText;
|
||||||
|
FBrowserCS.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetFailedURL : string;
|
||||||
|
begin
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
Result := FFailedURL;
|
||||||
|
FBrowserCS.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetInitialized : boolean;
|
||||||
|
begin
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
Result := not(Terminated) and (FStatus in [tsIdle, tsLoading]);
|
||||||
|
FBrowserCS.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetClosing : boolean;
|
||||||
|
begin
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
Result := (FStatus = tsClosing);
|
||||||
|
FBrowserCS.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetStatus : TThreadStatus;
|
||||||
|
begin
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
Result := FStatus;
|
||||||
|
FBrowserCS.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.GetFileName : string;
|
||||||
|
begin
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
Result := FFileName;
|
||||||
|
FBrowserCS.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.SetErrorText(const aValue : string);
|
||||||
|
begin
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
FErrorText := aValue;
|
||||||
|
FBrowserCS.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.SetFileName(const aValue : string);
|
||||||
|
begin
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
FFileName := aValue;
|
||||||
|
FBrowserCS.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.SetStatus(aValue : TThreadStatus);
|
||||||
|
begin
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
FStatus := aValue;
|
||||||
|
FBrowserCS.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.DoOnInitialized;
|
||||||
|
begin
|
||||||
|
if assigned(FOnInitialized) then
|
||||||
|
FOnInitialized(self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.DoOnError;
|
||||||
|
begin
|
||||||
|
if assigned(FOnError) then
|
||||||
|
FOnError(self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.DoOnSnapshotAvailable;
|
||||||
|
begin
|
||||||
|
if assigned(FOnSnapshotAvailable) then
|
||||||
|
FOnSnapshotAvailable(self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnAfterCreated(Sender: TObject;
|
||||||
|
const browser: ICefBrowser);
|
||||||
|
begin
|
||||||
|
Status := tsIdle;
|
||||||
|
DoOnInitialized;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnGetViewRect(Sender: TObject;
|
||||||
|
const browser: ICefBrowser; var rect: TCefRect);
|
||||||
|
begin
|
||||||
|
rect.x := 0;
|
||||||
|
rect.y := 0;
|
||||||
|
rect.width := FBrowserSize.cx;
|
||||||
|
rect.height := FBrowserSize.cy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnGetScreenInfo(Sender: TObject;
|
||||||
|
const browser: ICefBrowser; var screenInfo: TCefScreenInfo; out Result: Boolean);
|
||||||
|
var
|
||||||
|
TempRect : TCEFRect;
|
||||||
|
begin
|
||||||
|
TempRect.x := 0;
|
||||||
|
TempRect.y := 0;
|
||||||
|
TempRect.width := FBrowserSize.cx;
|
||||||
|
TempRect.height := FBrowserSize.cy;
|
||||||
|
|
||||||
|
screenInfo.device_scale_factor := 1;
|
||||||
|
screenInfo.depth := 0;
|
||||||
|
screenInfo.depth_per_component := 0;
|
||||||
|
screenInfo.is_monochrome := Ord(False);
|
||||||
|
screenInfo.rect := TempRect;
|
||||||
|
screenInfo.available_rect := TempRect;
|
||||||
|
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnBeforePopup(Sender: TObject;
|
||||||
|
const browser: ICefBrowser; const frame: ICefFrame;
|
||||||
|
const targetUrl, targetFrameName: ustring;
|
||||||
|
targetDisposition: TCefWindowOpenDisposition; userGesture: Boolean;
|
||||||
|
const popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo;
|
||||||
|
var client: ICefClient; var settings: TCefBrowserSettings;
|
||||||
|
var extra_info: ICefDictionaryValue; var noJavascriptAccess: Boolean;
|
||||||
|
var Result: Boolean);
|
||||||
|
begin
|
||||||
|
Result := (targetDisposition in [CEF_WOD_NEW_FOREGROUND_TAB,
|
||||||
|
CEF_WOD_NEW_BACKGROUND_TAB,
|
||||||
|
CEF_WOD_NEW_POPUP,
|
||||||
|
CEF_WOD_NEW_WINDOW]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnBeforeClose(Sender: TObject; const browser: ICefBrowser);
|
||||||
|
begin
|
||||||
|
Status := tsDestroyed;
|
||||||
|
EnqueueMessage(WORKERTHREADMSG_QUIT);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnLoadError(Sender: TObject;
|
||||||
|
const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer;
|
||||||
|
const errorText, failedUrl: ustring);
|
||||||
|
begin
|
||||||
|
if not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain then
|
||||||
|
try
|
||||||
|
FBrowserCS.Acquire;
|
||||||
|
FErrorCode := errorCode;
|
||||||
|
FErrorText := errorText;
|
||||||
|
FFailedUrl := failedUrl;
|
||||||
|
finally
|
||||||
|
FBrowserCS.Release;
|
||||||
|
EnqueueMessage(WORKERTHREADMSG_DOONERROR);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnLoadingStateChange(Sender: TObject;
|
||||||
|
const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean);
|
||||||
|
var
|
||||||
|
TempParams : ICefDictionaryValue;
|
||||||
|
begin
|
||||||
|
if isLoading then
|
||||||
|
Status := tsLoading
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
Status := tsIdle;
|
||||||
|
TempParams := TCefDictionaryValueRef.New;
|
||||||
|
TempParams.SetString('format', 'png');
|
||||||
|
FMessageID := FBrowser.ExecuteDevToolsMethod(0, 'Page.captureScreenshot', TempParams);
|
||||||
|
TempParams := nil;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnDevToolsMethodResult(Sender: TObject;
|
||||||
|
const browser: ICefBrowser; message_id: Integer; success: Boolean;
|
||||||
|
const result: ICefValue);
|
||||||
|
var
|
||||||
|
TempRsltDict : ICefDictionaryValue;
|
||||||
|
TempString : ustring;
|
||||||
|
TempBin : ICefBinaryValue;
|
||||||
|
TempStream : TFileStream;
|
||||||
|
TempSuccess : boolean;
|
||||||
|
begin
|
||||||
|
if not(success) or (FMessageID <> message_id) or not(assigned(result)) then exit;
|
||||||
|
|
||||||
|
TempSuccess := False;
|
||||||
|
TempStream := nil;
|
||||||
|
TempRsltDict := result.GetDictionary;
|
||||||
|
|
||||||
|
if assigned(TempRsltDict) then
|
||||||
|
try
|
||||||
|
if TCEFJson.ReadString(TempRsltDict, 'data', TempString) then
|
||||||
|
try
|
||||||
|
TempBin := CefBase64Decode(TempString);
|
||||||
|
|
||||||
|
if assigned(TempBin) and (TempBin.Size > 0) then
|
||||||
|
try
|
||||||
|
try
|
||||||
|
TempStream := TFileStream.Create(FileName, fmCreate);
|
||||||
|
TempStream.WriteBuffer(TempBin.GetRawData^, TempBin.Size);
|
||||||
|
TempSuccess := True;
|
||||||
|
except
|
||||||
|
on e : exception do
|
||||||
|
if CustomExceptionHandler('TCEFBrowserThread.Browser_OnDevToolsMethodResult', e) then raise;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
if assigned(TempStream) then
|
||||||
|
FreeAndNil(TempStream);
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
TempBin := nil;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
TempRsltDict := nil;
|
||||||
|
if TempSuccess then DoOnSnapshotAvailable;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Browser_OnOpenUrlFromTab(Sender: TObject;
|
||||||
|
const browser: ICefBrowser; const frame: ICefFrame; const targetUrl: ustring;
|
||||||
|
targetDisposition: TCefWindowOpenDisposition; userGesture: Boolean;
|
||||||
|
out Result: Boolean);
|
||||||
|
begin
|
||||||
|
Result := (targetDisposition in [CEF_WOD_NEW_FOREGROUND_TAB,
|
||||||
|
CEF_WOD_NEW_BACKGROUND_TAB,
|
||||||
|
CEF_WOD_NEW_POPUP,
|
||||||
|
CEF_WOD_NEW_WINDOW]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.ProcessValue(const aInfo : TMsgInfo);
|
||||||
|
begin
|
||||||
|
case aInfo.Msg of
|
||||||
|
WORKERTHREADMSG_LOADURL : DoLoadURL(aInfo.StrParam);
|
||||||
|
WORKERTHREADMSG_DOONERROR : DoOnError;
|
||||||
|
WORKERTHREADMSG_CLOSEBROWSER : CloseBrowser;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCEFBrowserThread.CreateBrowser : boolean;
|
||||||
|
begin
|
||||||
|
Result := assigned(FBrowser) and FBrowser.CreateBrowser;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.DoLoadURL(const aURL : string);
|
||||||
|
begin
|
||||||
|
if not(Terminated) and Initialized and assigned(FBrowser) then
|
||||||
|
FBrowser.LoadURL(aURL);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.CloseBrowser;
|
||||||
|
begin
|
||||||
|
if Initialized then
|
||||||
|
begin
|
||||||
|
if assigned(FBrowser) then
|
||||||
|
begin
|
||||||
|
Status := tsClosing;
|
||||||
|
FBrowser.CloseBrowser(True);
|
||||||
|
end;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
if not(Closing) then
|
||||||
|
EnqueueMessage(WORKERTHREADMSG_QUIT);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.InitError;
|
||||||
|
begin
|
||||||
|
Status := tsInitError;
|
||||||
|
ErrorText := 'There was an error initializing the CEF browser.';
|
||||||
|
DoOnError;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCEFBrowserThread.Execute;
|
||||||
|
begin
|
||||||
|
if CreateBrowser then
|
||||||
|
inherited Execute
|
||||||
|
else
|
||||||
|
InitError;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
@ -0,0 +1,37 @@
|
|||||||
|
unit ucustommessage;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils;
|
||||||
|
|
||||||
|
type
|
||||||
|
TMsgInfo = record
|
||||||
|
Msg : integer;
|
||||||
|
StrParam : string;
|
||||||
|
IntParam : integer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TCustomMessage = class
|
||||||
|
protected
|
||||||
|
FValue : TMsgInfo;
|
||||||
|
|
||||||
|
public
|
||||||
|
constructor Create(const aValue : TMsgInfo);
|
||||||
|
|
||||||
|
property Value : TMsgInfo read FValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
constructor TCustomMessage.Create(const aValue : TMsgInfo);
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
|
||||||
|
FValue := aValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
@ -0,0 +1,182 @@
|
|||||||
|
unit uencapsulatedbrowser;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
SyncObjs, SysUtils,
|
||||||
|
uCEFTypes, ucefbrowserthread;
|
||||||
|
|
||||||
|
type
|
||||||
|
TEncapsulatedBrowser = class
|
||||||
|
protected
|
||||||
|
FThread : TCEFBrowserThread;
|
||||||
|
FWidth : integer;
|
||||||
|
FHeight : integer;
|
||||||
|
FDelayMs : integer;
|
||||||
|
FScale : single;
|
||||||
|
FSnapshotPath : string;
|
||||||
|
FErrorText : string;
|
||||||
|
|
||||||
|
procedure Thread_OnError(Sender: TObject);
|
||||||
|
procedure Thread_OnSnapshotAvailable(Sender: TObject);
|
||||||
|
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure LoadURL(const aURL : string);
|
||||||
|
|
||||||
|
property Width : integer read FWidth write FWidth;
|
||||||
|
property Height : integer read FHeight write FHeight;
|
||||||
|
property SnapshotPath : string read FSnapshotPath write FSnapshotPath;
|
||||||
|
property ErrorText : string read FErrorText;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure CreateGlobalCEFApp;
|
||||||
|
function WaitForMainAppEvent : boolean;
|
||||||
|
procedure WriteResult;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
uCEFApplication;
|
||||||
|
|
||||||
|
var
|
||||||
|
MainAppEvent : TSimpleEvent;
|
||||||
|
EncapsulatedBrowser : TEncapsulatedBrowser = nil;
|
||||||
|
|
||||||
|
procedure GlobalCEFApp_OnContextInitialized;
|
||||||
|
var
|
||||||
|
TempParam, TempURL : ustring;
|
||||||
|
begin
|
||||||
|
TempURL := '';
|
||||||
|
|
||||||
|
// This demo reads the "/url" parameter to load it as the default URL in the browser.
|
||||||
|
// For example : ConsoleBrowser2.exe /url=https://www.briskbard.com
|
||||||
|
if (ParamCount > 0) then
|
||||||
|
begin
|
||||||
|
TempParam := paramstr(1);
|
||||||
|
|
||||||
|
if (Copy(TempParam, 1, 5) = '/url=') then
|
||||||
|
begin
|
||||||
|
TempURL := trim(Copy(TempParam, 6, length(TempParam)));
|
||||||
|
if (length(TempURL) > 0) then WriteLn('Loading ' + TempURL);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if (length(TempURL) = 0) then
|
||||||
|
begin
|
||||||
|
TempURL := 'https://www.google.com';
|
||||||
|
WriteLn('No URL has been specified. Using the default...');
|
||||||
|
end;
|
||||||
|
|
||||||
|
EncapsulatedBrowser := TEncapsulatedBrowser.Create;
|
||||||
|
EncapsulatedBrowser.LoadURL(TempURL);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function WaitForMainAppEvent : boolean;
|
||||||
|
begin
|
||||||
|
Result := True;
|
||||||
|
|
||||||
|
// Wait for 1 minute max.
|
||||||
|
if (MainAppEvent.WaitFor(60000) = wrTimeout) then
|
||||||
|
begin
|
||||||
|
WriteLn('Timeout expired!');
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure WriteResult;
|
||||||
|
begin
|
||||||
|
if (EncapsulatedBrowser = nil) then
|
||||||
|
WriteLn('There was a problem in the browser initialization')
|
||||||
|
else
|
||||||
|
if (length(EncapsulatedBrowser.ErrorText) > 0) then
|
||||||
|
WriteLn(EncapsulatedBrowser.ErrorText)
|
||||||
|
else
|
||||||
|
WriteLn('Snapshot saved successfully as ' + EncapsulatedBrowser.SnapshotPath);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure CreateGlobalCEFApp;
|
||||||
|
begin
|
||||||
|
GlobalCEFApp := TCefApplication.Create;
|
||||||
|
GlobalCEFApp.WindowlessRenderingEnabled := True;
|
||||||
|
GlobalCEFApp.ShowMessageDlg := False; // This demo shouldn't show any window, just console messages.
|
||||||
|
GlobalCEFApp.BrowserSubprocessPath := 'consolebrowser_sp'; // This is the other EXE for the CEF subprocesses. It's on the same directory as this app.
|
||||||
|
GlobalCEFApp.BlinkSettings := 'hideScrollbars'; // This setting removes all scrollbars to capture a cleaner snapshot
|
||||||
|
GlobalCEFApp.OnContextInitialized := @GlobalCEFApp_OnContextInitialized;
|
||||||
|
GlobalCEFApp.SetCurrentDir := True;
|
||||||
|
GlobalCEFApp.DisableZygote := True;
|
||||||
|
GlobalCEFApp.StartMainProcess;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TEncapsulatedBrowser.Create;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
|
||||||
|
FThread := nil;
|
||||||
|
FWidth := 1024;
|
||||||
|
FHeight := 768;
|
||||||
|
FSnapshotPath := 'snapshot.png';
|
||||||
|
FErrorText := '';
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TEncapsulatedBrowser.Destroy;
|
||||||
|
begin
|
||||||
|
if (FThread <> nil) then
|
||||||
|
begin
|
||||||
|
FThread.TerminateBrowserThread;
|
||||||
|
FThread.WaitFor;
|
||||||
|
FreeAndNil(FThread);
|
||||||
|
end;
|
||||||
|
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TEncapsulatedBrowser.LoadURL(const aURL : string);
|
||||||
|
begin
|
||||||
|
if (FThread = nil) then
|
||||||
|
begin
|
||||||
|
FThread := TCEFBrowserThread.Create(FWidth, FHeight, aURL, FSnapshotPath);
|
||||||
|
FThread.OnError := @Thread_OnError;
|
||||||
|
FThread.OnSnapshotAvailable := @Thread_OnSnapshotAvailable;
|
||||||
|
FThread.Start;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
FThread.LoadUrl(aURL);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TEncapsulatedBrowser.Thread_OnError(Sender: TObject);
|
||||||
|
begin
|
||||||
|
// This code is executed in the TCEFBrowserThread thread context while the main application thread is waiting for MainAppEvent.
|
||||||
|
|
||||||
|
FErrorText := 'Error';
|
||||||
|
|
||||||
|
if (FThread.ErrorCode <> 0) then
|
||||||
|
FErrorText := FErrorText + ' ' + inttostr(FThread.ErrorCode);
|
||||||
|
|
||||||
|
FErrorText := FErrorText + ' : ' + FThread.ErrorText;
|
||||||
|
|
||||||
|
if (length(FThread.FailedUrl) > 0) then
|
||||||
|
FErrorText := FErrorText + ' - ' + FThread.FailedUrl;
|
||||||
|
|
||||||
|
if assigned(MainAppEvent) then
|
||||||
|
MainAppEvent.SetEvent;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TEncapsulatedBrowser.Thread_OnSnapshotAvailable(Sender: TObject);
|
||||||
|
begin
|
||||||
|
// This code is executed in the TCEFBrowserThread thread context while the main application thread is waiting for MainAppEvent.
|
||||||
|
if assigned(MainAppEvent) then
|
||||||
|
MainAppEvent.SetEvent;
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
MainAppEvent := TSimpleEvent.Create;
|
||||||
|
|
||||||
|
finalization
|
||||||
|
MainAppEvent.Free;
|
||||||
|
if (EncapsulatedBrowser <> nil) then FreeAndNil(EncapsulatedBrowser);
|
||||||
|
|
||||||
|
end.
|
||||||
210
demos/Lazarus_Linux_Console/ConsoleBrowser/uworkerthread.pas
Normal file
210
demos/Lazarus_Linux_Console/ConsoleBrowser/uworkerthread.pas
Normal file
@ -0,0 +1,210 @@
|
|||||||
|
unit uworkerthread;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, SyncObjs, Contnrs,
|
||||||
|
ucustommessage;
|
||||||
|
|
||||||
|
const
|
||||||
|
WORKERTHREADMSG_QUIT = 1;
|
||||||
|
|
||||||
|
type
|
||||||
|
TWorkerThread = class(TThread)
|
||||||
|
protected
|
||||||
|
FCritSect : TCriticalSection;
|
||||||
|
FEvent : TEvent;
|
||||||
|
FWaiting : boolean;
|
||||||
|
FStop : boolean;
|
||||||
|
FMsgQueue : TObjectQueue;
|
||||||
|
|
||||||
|
function Lock : boolean;
|
||||||
|
procedure Unlock;
|
||||||
|
function CanContinue : boolean;
|
||||||
|
procedure ReadAllPendingMessages;
|
||||||
|
procedure ProcessValue(const aInfo : TMsgInfo); virtual;
|
||||||
|
function ReadPendingMessage(var aMsgInfo : TMsgInfo) : boolean;
|
||||||
|
procedure StopThread;
|
||||||
|
procedure DestroyQueue;
|
||||||
|
procedure EnqueueMessage(const aMsgInfo : TMsgInfo); overload;
|
||||||
|
procedure EnqueueMessage(aMsg: integer; aIntParam : integer = 0; const aStrParam : string = ''); overload;
|
||||||
|
|
||||||
|
procedure Execute; override;
|
||||||
|
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure AfterConstruction; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
|
||||||
|
constructor TWorkerThread.Create;
|
||||||
|
begin
|
||||||
|
FCritSect := nil;
|
||||||
|
FWaiting := False;
|
||||||
|
FStop := False;
|
||||||
|
FEvent := nil;
|
||||||
|
FMsgQueue := nil;
|
||||||
|
|
||||||
|
inherited Create(True);
|
||||||
|
|
||||||
|
FreeOnTerminate := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TWorkerThread.Destroy;
|
||||||
|
begin
|
||||||
|
if (FEvent <> nil) then FreeAndNil(FEvent);
|
||||||
|
if (FCritSect <> nil) then FreeAndNil(FCritSect);
|
||||||
|
|
||||||
|
DestroyQueue;
|
||||||
|
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TWorkerThread.DestroyQueue;
|
||||||
|
begin
|
||||||
|
if (FMsgQueue <> nil) then
|
||||||
|
begin
|
||||||
|
while (FMsgQueue.Count > 0) do
|
||||||
|
FMsgQueue.Pop.Free;
|
||||||
|
|
||||||
|
FreeAndNil(FMsgQueue);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TWorkerThread.AfterConstruction;
|
||||||
|
begin
|
||||||
|
inherited AfterConstruction;
|
||||||
|
|
||||||
|
FEvent := TEvent.Create(nil, False, False, '');
|
||||||
|
FCritSect := TCriticalSection.Create;
|
||||||
|
FMsgQueue := TObjectQueue.Create;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TWorkerThread.Lock : boolean;
|
||||||
|
begin
|
||||||
|
if (FCritSect <> nil) then
|
||||||
|
begin
|
||||||
|
FCritSect.Acquire;
|
||||||
|
Result := True;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TWorkerThread.Unlock;
|
||||||
|
begin
|
||||||
|
if (FCritSect <> nil) then FCritSect.Release;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TWorkerThread.StopThread;
|
||||||
|
begin
|
||||||
|
if Lock then
|
||||||
|
begin
|
||||||
|
FStop := True;
|
||||||
|
Unlock;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TWorkerThread.EnqueueMessage(aMsg, aIntParam : integer; const aStrParam : string);
|
||||||
|
var
|
||||||
|
TempMsgInfo : TMsgInfo;
|
||||||
|
begin
|
||||||
|
TempMsgInfo.Msg := aMsg;
|
||||||
|
TempMsgInfo.StrParam := aStrParam;
|
||||||
|
TempMsgInfo.IntParam := aIntParam;
|
||||||
|
EnqueueMessage(TempMsgInfo);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TWorkerThread.EnqueueMessage(const aMsgInfo : TMsgInfo);
|
||||||
|
begin
|
||||||
|
if Lock then
|
||||||
|
try
|
||||||
|
if (FMsgQueue <> nil) then
|
||||||
|
FMsgQueue.Push(TCustomMessage.Create(aMsgInfo));
|
||||||
|
|
||||||
|
if FWaiting then
|
||||||
|
begin
|
||||||
|
FWaiting := False;
|
||||||
|
FEvent.SetEvent;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
Unlock;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TWorkerThread.ReadPendingMessage(var aMsgInfo : TMsgInfo) : boolean;
|
||||||
|
var
|
||||||
|
TempMessage : TCustomMessage;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
|
||||||
|
if Lock then
|
||||||
|
try
|
||||||
|
FWaiting := False;
|
||||||
|
|
||||||
|
if (FMsgQueue <> nil) and (FMsgQueue.Count > 0) then
|
||||||
|
begin
|
||||||
|
TempMessage := TCustomMessage(FMsgQueue.Pop);
|
||||||
|
aMsgInfo := TempMessage.Value;
|
||||||
|
Result := True;
|
||||||
|
TempMessage.Free;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
Unlock;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TWorkerThread.ReadAllPendingMessages;
|
||||||
|
var
|
||||||
|
TempInfo : TMsgInfo;
|
||||||
|
begin
|
||||||
|
while ReadPendingMessage(TempInfo) do
|
||||||
|
case TempInfo.Msg of
|
||||||
|
WORKERTHREADMSG_QUIT :
|
||||||
|
begin
|
||||||
|
StopThread;
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
|
||||||
|
else ProcessValue(TempInfo);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TWorkerThread.ProcessValue(const aInfo : TMsgInfo);
|
||||||
|
begin
|
||||||
|
//
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TWorkerThread.CanContinue : boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
|
||||||
|
if Lock then
|
||||||
|
try
|
||||||
|
if not(Terminated) and not(FStop) then
|
||||||
|
begin
|
||||||
|
Result := True;
|
||||||
|
FWaiting := True;
|
||||||
|
FEvent.ResetEvent;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
Unlock;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TWorkerThread.Execute;
|
||||||
|
begin
|
||||||
|
while CanContinue do
|
||||||
|
begin
|
||||||
|
FEvent.WaitFor(INFINITE);
|
||||||
|
ReadAllPendingMessages;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
@ -2,7 +2,7 @@
|
|||||||
"UpdateLazPackages" : [
|
"UpdateLazPackages" : [
|
||||||
{
|
{
|
||||||
"ForceNotify" : true,
|
"ForceNotify" : true,
|
||||||
"InternalVersion" : 573,
|
"InternalVersion" : 574,
|
||||||
"Name" : "cef4delphi_lazarus.lpk",
|
"Name" : "cef4delphi_lazarus.lpk",
|
||||||
"Version" : "122.1.12"
|
"Version" : "122.1.12"
|
||||||
}
|
}
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user