CEF4Delphi/demos/Delphi_VCL/ConsoleBrowser2/uCEFBrowserThread.pas

unit uCEFBrowserThread;

{$I ..\..\..\source\cef.inc}

interface

uses
  {$IFDEF DELPHI16_UP}
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, System.SyncObjs, System.Math,
  {$ELSE}
  Windows, Messages, SysUtils, Classes, Graphics, SyncObjs, Math,
  {$ENDIF}
  uCEFChromium, uCEFTypes, uCEFInterfaces, uCEFConstants, uCEFBrowserBitmap, uCEFChromiumCore, uCEFMiscFunctions;

type
  TCEFBrowserThread = class(TThread)
    protected
      FBrowser               : TChromium;
      FBrowserBitmap         : TCEFBrowserBitmap;
      FBrowserSize           : TSize;
      FScreenScale           : single;
      FPopUpBitmap           : TBitmap;
      FPopUpRect             : TRect;
      FResizeCS              : TCriticalSection;
      FBrowserInfoCS         : TCriticalSection;
      FShowPopUp             : boolean;
      FClosing               : boolean;
      FResizing              : boolean;
      FPendingResize         : boolean;
      FInitialized           : boolean;
      FDefaultURL            : ustring;
      FDelayMs               : integer;
      FOnSnapshotAvailable   : TNotifyEvent;
      FOnError               : TNotifyEvent;
      FErrorCode             : integer;
      FErrorText             : ustring;
      FFailedUrl             : ustring;
      FPendingUrl            : ustring;
      FSyncEvents            : boolean;

      function  GetErrorCode : integer;
      function  GetErrorText : ustring;
      function  GetFailedUrl : ustring;
      function  GetInitialized : boolean;

      procedure SetErrorText(const aValue : ustring);

      procedure Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
      procedure Browser_OnPaint(Sender: TObject; const browser: ICefBrowser; kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; const buffer: Pointer; aWidth, aHeight: Integer);
      procedure Browser_OnGetViewRect(Sender: TObject; const browser: ICefBrowser; var rect: TCefRect);
      procedure Browser_OnGetScreenPoint(Sender: TObject; const browser: ICefBrowser; viewX, viewY: Integer; var screenX, screenY: Integer; out Result: Boolean);
      procedure Browser_OnGetScreenInfo(Sender: TObject; const browser: ICefBrowser; var screenInfo: TCefScreenInfo; out Result: Boolean);
      procedure Browser_OnPopupShow(Sender: TObject; const browser: ICefBrowser; show: Boolean);
      procedure Browser_OnPopupSize(Sender: TObject; const browser: ICefBrowser; const rect: PCefRect);
      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 DoOnError;
      procedure DoOnSnapshotAvailable;
      procedure Resize;
      function  CreateBrowser : boolean;
      procedure CloseBrowser;
      procedure InitError;
      procedure WebpagePostProcessing;
      procedure WebpageError;
      procedure LoadPendingURL;
      procedure Execute; override;

    public
      constructor Create(const aDefaultURL : ustring; aWidth, aHeight : integer; aDelayMs : integer = 500; const aScreenScale : single = 1);
      destructor  Destroy; override;
      procedure   AfterConstruction; override;
      function    TerminateBrowserThread : boolean;
      function    CopySnapshot(var aSnapshot : TBitmap) : boolean;
      function    SaveSnapshotToFile(const aPath : ustring) : boolean;
      procedure   LoadUrl(const aURL : ustring);

      property ErrorCode             : integer           read GetErrorCode;
      property ErrorText             : ustring           read GetErrorText             write SetErrorText;
      property FailedUrl             : ustring           read GetFailedUrl;
      property Initialized           : boolean           read GetInitialized;
      property Closing               : boolean           read FClosing;
      property SyncEvents            : boolean           read FSyncEvents              write FSyncEvents;

      property OnSnapshotAvailable   : TNotifyEvent      read FOnSnapshotAvailable     write FOnSnapshotAvailable;
      property OnError               : TNotifyEvent      read FOnError                 write FOnError;
  end;

implementation

const
  CEF_WEBPAGE_LOADED_MSG   = WM_APP + 1;
  CEF_WEBPAGE_ERROR_MSG    = WM_APP + 2;
  CEF_CLOSE_BROWSER_MSG    = WM_APP + 3;
  CEF_LOAD_PENDING_URL_MSG = WM_APP + 4;

constructor TCEFBrowserThread.Create(const aDefaultURL : ustring; aWidth, aHeight, aDelayMs : integer; const aScreenScale : single);
begin
  inherited Create(True);

  FreeOnTerminate        := False;
  FInitialized           := False;
  FBrowser               := nil;
  FBrowserBitmap         := nil;
  FBrowserSize.cx        := aWidth;
  FBrowserSize.cy        := aHeight;
  FScreenScale           := aScreenScale;
  FDefaultURL            := aDefaultURL;
  FPopUpBitmap           := nil;
  FPopUpRect             := rect(0, 0, 0, 0);
  FShowPopUp             := False;
  FResizing              := False;
  FPendingResize         := False;
  FResizeCS              := nil;
  FBrowserInfoCS         := nil;
  FDelayMs               := aDelayMs;
  FOnSnapshotAvailable   := nil;
  FOnError               := nil;
  FClosing               := False;
  FSyncEvents            := False;
end;

destructor TCEFBrowserThread.Destroy;
begin
  if (FBrowser <> nil) then
    FreeAndNil(FBrowser);

  if (FBrowserBitmap <> nil) then
    FreeAndNil(FBrowserBitmap);

  if (FPopUpBitmap <> nil) then
    FreeAndNil(FPopUpBitmap);

  if (FResizeCS <> nil) then
    FreeAndNil(FResizeCS);

  if (FBrowserInfoCS <> nil) then
    FreeAndNil(FBrowserInfoCS);

  inherited Destroy;
end;

procedure TCEFBrowserThread.AfterConstruction;
begin
  inherited AfterConstruction;

  FResizeCS                        := TCriticalSection.Create;
  FBrowserInfoCS                   := TCriticalSection.Create;

  FBrowserBitmap                   := TCEFBrowserBitmap.Create;
  FBrowserBitmap.PixelFormat       := pf32bit;
  FBrowserBitmap.HandleType        := bmDIB;
  FBrowserBitmap.DeviceScaleFactor := FScreenScale;
  FBrowserBitmap.SetSize(FBrowserSize.cx, FBrowserSize.cy);

  FBrowser                         := TChromium.Create(nil);
  FBrowser.DefaultURL              := FDefaultURL;
  FBrowser.Options.BackgroundColor := CefColorSetARGB($FF, $FF, $FF, $FF);
  FBrowser.OnAfterCreated          := Browser_OnAfterCreated;
  FBrowser.OnPaint                 := Browser_OnPaint;
  FBrowser.OnGetViewRect           := Browser_OnGetViewRect;
  FBrowser.OnGetScreenPoint        := Browser_OnGetScreenPoint;
  FBrowser.OnGetScreenInfo         := Browser_OnGetScreenInfo;
  FBrowser.OnPopupShow             := Browser_OnPopupShow;
  FBrowser.OnPopupSize             := Browser_OnPopupSize;
  FBrowser.OnBeforePopup           := Browser_OnBeforePopup;
  FBrowser.OnBeforeClose           := Browser_OnBeforeClose;
  FBrowser.OnLoadError             := Browser_OnLoadError;
  FBrowser.OnLoadingStateChange    := Browser_OnLoadingStateChange;
end;

function TCEFBrowserThread.GetErrorCode : integer;
begin
  if assigned(FBrowserInfoCS) then
    try
      FBrowserInfoCS.Acquire;
      Result := FErrorCode;
    finally
      FBrowserInfoCS.Release;
    end
   else
    Result := 0;
end;

function TCEFBrowserThread.GetErrorText : ustring;
begin
  if assigned(FBrowserInfoCS) then
    try
      FBrowserInfoCS.Acquire;
      Result := FErrorText;
    finally
      FBrowserInfoCS.Release;
    end
   else
    Result := '';
end;

function TCEFBrowserThread.GetFailedUrl : ustring;
begin
  if assigned(FBrowserInfoCS) then
    try
      FBrowserInfoCS.Acquire;
      Result := FFailedUrl;
    finally
      FBrowserInfoCS.Release;
    end
   else
    Result := '';
end;

function TCEFBrowserThread.GetInitialized : boolean;
begin
  Result := False;

  if assigned(FBrowserInfoCS) and assigned(FBrowser) then
    try
      FBrowserInfoCS.Acquire;
      Result := FInitialized and FBrowser.Initialized;
    finally
      FBrowserInfoCS.Release;
    end;
end;

procedure TCEFBrowserThread.SetErrorText(const aValue : ustring);
begin
  if assigned(FBrowserInfoCS) then
    try
      FBrowserInfoCS.Acquire;
      FErrorText := aValue;
    finally
      FBrowserInfoCS.Release;
    end;
end;

function TCEFBrowserThread.CopySnapshot(var aSnapshot : TBitmap) : boolean;
begin
  Result := False;

  if FClosing or Terminated or not(Initialized) then exit;

  if assigned(FBrowserInfoCS) then
    try
      try
        FBrowserInfoCS.Acquire;

        if assigned(FBrowserBitmap) and not(FBrowserBitmap.Empty) then
          begin
            if (aSnapshot = nil) then
              begin
                aSnapshot             := TBitmap.Create;
                aSnapshot.PixelFormat := pf32bit;
                aSnapshot.HandleType  := bmDIB;
              end;

            if (aSnapshot.Width <> FBrowserBitmap.Width) then
              aSnapshot.Width := FBrowserBitmap.Width;

            if (aSnapshot.Height <> FBrowserBitmap.Height) then
              aSnapshot.Height := FBrowserBitmap.Height;

            aSnapshot.Canvas.Draw(0, 0, FBrowserBitmap);
            Result := True;
          end;
      except
        on e : exception do
          if CustomExceptionHandler('TCEFBrowserThread.CopySnapshot', e) then raise;
      end;
    finally
      FBrowserInfoCS.Release;
    end;
end;

function TCEFBrowserThread.SaveSnapshotToFile(const aPath : ustring) : boolean;
begin
  Result := False;

  if FClosing or Terminated or not(Initialized) then exit;

  if assigned(FBrowserInfoCS) and (length(aPath) > 0) then
    try
      try
        FBrowserInfoCS.Acquire;

        if assigned(FBrowserBitmap) and not(FBrowserBitmap.Empty) then
          begin
            FBrowserBitmap.SaveToFile(aPath);
            Result := True;
          end;
      except
        on e : exception do
          if CustomExceptionHandler('TCEFBrowserThread.SaveSnapshotToFile', e) then raise;
      end;
    finally
      FBrowserInfoCS.Release;
    end;
end;

procedure TCEFBrowserThread.LoadUrl(const aURL : ustring);
begin
  if FClosing or Terminated or not(Initialized) then exit;

  if assigned(FBrowserInfoCS) then
    try
      FBrowserInfoCS.Acquire;
      FPendingUrl := aURL;
      PostThreadMessage(ThreadID, CEF_LOAD_PENDING_URL_MSG, 0, 0);
    finally
      FBrowserInfoCS.Release;
    end;
end;

function TCEFBrowserThread.TerminateBrowserThread : boolean;
begin
  Result := Initialized and
            PostThreadMessage(ThreadID, CEF_CLOSE_BROWSER_MSG, 0, 0);
end;

procedure TCEFBrowserThread.Browser_OnAfterCreated(Sender: TObject; const browser: ICefBrowser);
begin
  if assigned(FBrowserInfoCS) then
    try
      FBrowserInfoCS.Acquire;
      FInitialized := True;
    finally
      FBrowserInfoCS.Release;
    end;
end;

procedure TCEFBrowserThread.Browser_OnPaint(Sender: TObject; const browser: ICefBrowser; kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; const buffer: Pointer; aWidth, aHeight: Integer);
var
  src, dst: PByte;
  i, j, TempLineSize, TempSrcOffset, TempDstOffset, SrcStride, DstStride : Integer;
  n : NativeUInt;
  TempWidth, TempHeight, TempScanlineSize : integer;
  TempBufferBits : Pointer;
  TempForcedResize : boolean;
  TempSrcRect : TRect;
begin
  if assigned(FResizeCS) and assigned(FBrowserBitmap) then
    try
      FResizeCS.Acquire;
      TempForcedResize := False;

      if FBrowserBitmap.BeginBufferDraw then
        begin
          if (kind = PET_POPUP) then
            begin
              if (FPopUpBitmap = nil) or
                 (aWidth  <> FPopUpBitmap.Width) or
                 (aHeight <> FPopUpBitmap.Height) then
                begin
                  if (FPopUpBitmap <> nil) then FPopUpBitmap.Free;

                  FPopUpBitmap             := TBitmap.Create;
                  FPopUpBitmap.PixelFormat := pf32bit;
                  FPopUpBitmap.HandleType  := bmDIB;
                  FPopUpBitmap.Width       := aWidth;
                  FPopUpBitmap.Height      := aHeight;
                end;

              TempWidth        := FPopUpBitmap.Width;
              TempHeight       := FPopUpBitmap.Height;
              TempScanlineSize := FPopUpBitmap.Width * SizeOf(TRGBQuad);
              TempBufferBits   := FPopUpBitmap.Scanline[pred(FPopUpBitmap.Height)];
            end
           else
            begin
              TempForcedResize := FBrowserBitmap.UpdateBufferDimensions(aWidth, aHeight) or not(FBrowserBitmap.BufferIsResized(False));
              TempWidth        := FBrowserBitmap.Width;
              TempHeight       := FBrowserBitmap.Height;
              TempScanlineSize := FBrowserBitmap.ScanlineSize;
              TempBufferBits   := FBrowserBitmap.BufferBits;
            end;

          if (TempBufferBits <> nil) then
            begin
              SrcStride := aWidth * SizeOf(TRGBQuad);
              DstStride := - TempScanlineSize;

              n := 0;

              while (n < dirtyRectsCount) do
                begin
                  if (dirtyRects[n].x >= 0) and (dirtyRects[n].y >= 0) then
                    begin
                      TempLineSize := min(dirtyRects[n].width, TempWidth - dirtyRects[n].x) * SizeOf(TRGBQuad);

                      if (TempLineSize > 0) then
                        begin
                          TempSrcOffset := ((dirtyRects[n].y * aWidth) + dirtyRects[n].x) * SizeOf(TRGBQuad);
                          TempDstOffset := ((TempScanlineSize * pred(TempHeight)) - (dirtyRects[n].y * TempScanlineSize)) +
                                           (dirtyRects[n].x * SizeOf(TRGBQuad));

                          src := @PByte(buffer)[TempSrcOffset];
                          dst := @PByte(TempBufferBits)[TempDstOffset];

                          i := 0;
                          j := min(dirtyRects[n].height, TempHeight - dirtyRects[n].y);

                          while (i < j) do
                            begin
                              Move(src^, dst^, TempLineSize);

                              Inc(dst, DstStride);
                              Inc(src, SrcStride);
                              inc(i);
                            end;
                        end;
                    end;

                  inc(n);
                end;

              if FShowPopup and (FPopUpBitmap <> nil) then
                begin
                  TempSrcRect := Rect(0, 0,
                                      min(FPopUpRect.Right  - FPopUpRect.Left, FPopUpBitmap.Width),
                                      min(FPopUpRect.Bottom - FPopUpRect.Top,  FPopUpBitmap.Height));

                  FBrowserBitmap.BufferDraw(FPopUpBitmap, TempSrcRect, FPopUpRect);
                end;
            end;

          FBrowserBitmap.EndBufferDraw;

          if (kind = PET_VIEW) then
            begin
              if TempForcedResize or FPendingResize then
                PostThreadMessage(ThreadID, CEF_PENDINGRESIZE, 0, 0);

              FResizing      := False;
              FPendingResize := False;
            end;
        end;
    finally
      FResizeCS.Release;
    end;
end;

procedure TCEFBrowserThread.Browser_OnGetViewRect(Sender: TObject; const browser: ICefBrowser; var rect: TCefRect);
begin
  rect.x      := 0;
  rect.y      := 0;
  rect.width  := DeviceToLogical(FBrowserBitmap.Width,  FScreenScale);
  rect.height := DeviceToLogical(FBrowserBitmap.Height, FScreenScale);
end;

procedure TCEFBrowserThread.Browser_OnGetScreenPoint(Sender: TObject; const browser: ICefBrowser; viewX, viewY: Integer; var screenX, screenY: Integer; out Result: Boolean);
begin
  screenX := LogicalToDevice(viewX, FScreenScale);
  screenY := LogicalToDevice(viewY, FScreenScale);
  Result  := True;
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  := DeviceToLogical(FBrowserBitmap.Width,  FScreenScale);
  TempRect.height := DeviceToLogical(FBrowserBitmap.Height, FScreenScale);

  screenInfo.device_scale_factor := FScreenScale;
  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_OnPopupShow(Sender: TObject; const browser: ICefBrowser; show: Boolean);
begin
  if show then
    FShowPopUp := True
   else
    begin
      FShowPopUp := False;
      FPopUpRect := rect(0, 0, 0, 0);

      if (FBrowser <> nil) then FBrowser.Invalidate(PET_VIEW);
    end;
end;

procedure TCEFBrowserThread.Browser_OnPopupSize(Sender: TObject; const browser: ICefBrowser; const rect: PCefRect);
begin
  LogicalToDevice(rect^, FScreenScale);

  FPopUpRect.Left   := rect.x;
  FPopUpRect.Top    := rect.y;
  FPopUpRect.Right  := rect.x + rect.width  - 1;
  FPopUpRect.Bottom := rect.y + rect.height - 1;
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
  // For simplicity, this demo blocks all popup windows and new tabs
  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
  PostThreadMessage(ThreadID, WM_QUIT, 0, 0);
end;

procedure TCEFBrowserThread.Browser_OnLoadError(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; const errorText, failedUrl: ustring);
begin
  if not(FClosing) and not(Terminated) and (frame <> nil) and frame.IsValid and frame.IsMain and assigned(FBrowserInfoCS) then
    try
      FBrowserInfoCS.Acquire;

      FErrorCode := errorCode;
      FErrorText := errorText;
      FFailedUrl := failedUrl;

      PostThreadMessage(ThreadID, CEF_WEBPAGE_ERROR_MSG, 0, 0);
    finally
      FBrowserInfoCS.Release;
    end;
end;

procedure TCEFBrowserThread.Browser_OnLoadingStateChange(Sender: TObject; const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean);
begin
  if not(FClosing) and not(Terminated) and not(isLoading) then
    PostThreadMessage(ThreadID, CEF_WEBPAGE_LOADED_MSG, 0, 0);
end;

procedure TCEFBrowserThread.Resize;
begin
  if FClosing or Terminated or not(Initialized) then exit;

  if assigned(FResizeCS) and assigned(FBrowserBitmap) then
    try
      FResizeCS.Acquire;

      if FResizing then
        FPendingResize := True
       else
        if FBrowserBitmap.BufferIsResized then
          FBrowser.Invalidate(PET_VIEW)
         else
          begin
            FResizing := True;
            FBrowser.WasResized;
          end;
    finally
      FResizeCS.Release;
    end;
end;

function TCEFBrowserThread.CreateBrowser : boolean;
begin
  Result := (FBrowser <> nil) and FBrowser.CreateBrowser;
end;

procedure TCEFBrowserThread.LoadPendingURL;
begin
  if FClosing or Terminated or not(Initialized) then exit;

  if assigned(FBrowserInfoCS) then
    try
      FBrowserInfoCS.Acquire;

      if (length(FPendingURL) > 0) then
        begin
          FBrowser.LoadURL(FPendingURL);
          FPendingURL := '';
        end;
    finally
      FBrowserInfoCS.Release;
    end;
end;

procedure TCEFBrowserThread.WebpagePostProcessing;
begin
  if FClosing or Terminated then
    exit;

  if (FDelayMs > 0) then
    sleep(FDelayMs);

  if assigned(FOnSnapshotAvailable) then
    begin
      if FSyncEvents then
        Synchronize(DoOnSnapshotAvailable)
       else
        DoOnSnapshotAvailable;
    end;
end;

procedure TCEFBrowserThread.WebpageError;
begin
  if not(FClosing) and not(Terminated) and assigned(FOnError) then
    begin
      if FSyncEvents then
        Synchronize(DoOnError)
       else
        DoOnError;
    end;
end;

procedure TCEFBrowserThread.CloseBrowser;
begin
  if not(FClosing) and assigned(FBrowser) then
    begin
      FClosing := True;
      FBrowser.CloseBrowser(True);
    end;
end;

procedure TCEFBrowserThread.DoOnError;
begin
  FOnError(self);
end;

procedure TCEFBrowserThread.DoOnSnapshotAvailable;
begin
  FOnSnapshotAvailable(self);
end;

procedure TCEFBrowserThread.InitError;
begin
  ErrorText := 'There was an error initializing the CEF browser.';

  if FSyncEvents then
    Synchronize(DoOnError)
   else
    DoOnError;
end;

procedure TCEFBrowserThread.Execute;
var
  TempCont : boolean;
  TempMsg  : TMsg;
begin
  if CreateBrowser then
    begin
      TempCont := True;
      PeekMessage(TempMsg, 0, WM_USER, WM_USER, PM_NOREMOVE);

      while TempCont and GetMessage(TempMsg, 0, 0, 0) and not(Terminated) do
        begin
          case TempMsg.Message of
            CEF_PENDINGRESIZE        : Resize;
            CEF_CLOSE_BROWSER_MSG    : CloseBrowser;
            CEF_LOAD_PENDING_URL_MSG : LoadPendingURL;
            CEF_WEBPAGE_LOADED_MSG   : WebpagePostProcessing;
            CEF_WEBPAGE_ERROR_MSG    : WebpageError;
            WM_QUIT                  : TempCont := False;
          end;

          DispatchMessage(TempMsg);
        end;
    end
   else
    InitError;
end;

end.