mirror of
https://github.com/salvadordf/CEF4Delphi.git
synced 2024-11-16 00:05:55 +01:00
444 lines
14 KiB
ObjectPascal
444 lines
14 KiB
ObjectPascal
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: TCefErrorcode; 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: TCefErrorcode;
|
|
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.
|