winapi: started

src/winapi/fresnel.winapi.pas

@@ -0,0 +1,551 @@
+unit Fresnel.WinApi;
+
+{$mode objfpc}{$H+}
+{$IF FPC_FULLVERSION>30300}
+{$WARN 6060 off : Case statement does not handle all possible cases}
+{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}
+{$ENDIF}
+
+interface
+
+uses
+  Classes, SysUtils,
+  Windows, JwaWinGDI, System.UITypes,
+  {$IFDEF FresnelSkia}
+  // skia
+  System.Skia, Fresnel.SkiaRenderer,
+  {$ENDIF}
+  // fresnel
+  Fresnel.Classes, Fresnel.Forms, Fresnel.WidgetSet, Fresnel.DOM,
+  Fresnel.Events, FCL.Events;
+
+type
+  {$IFDEF FresnelSkia}
+  TWinApiFontEngine = TFresnelSkiaFontEngine;
+  TWinApiRenderer = TFresnelSkiaRenderer;
+  {$ENDIF}
+
+  { TWinApiWSForm }
+
+  TWinApiWSForm = class(TFresnelWSForm)
+  private
+    FForm: TFresnelCustomForm;
+    FWindow: HWND;
+    procedure SetForm(AValue: TFresnelCustomForm);
+  protected
+    FDrawBuffer: HBITMAP;
+    FDrawBufferData: Pointer;
+    FDrawBufferStride: integer;
+    FDrawBufferSize: TSize;
+    function GetCaption: TFresnelCaption; override;
+    function GetFormBounds: TFresnelRect; override;
+    function GetVisible: boolean; override;
+    procedure DeleteDrawBuffer; virtual;
+    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    procedure RegisterWindowClass(const aClassName: PChar); virtual;
+    procedure SetCaption(AValue: TFresnelCaption); override;
+    procedure SetFormBounds(const AValue: TFresnelRect); override;
+    procedure SetVisible(const AValue: boolean); override;
+  public
+    function GetClientSize: TFresnelPoint; override;
+    procedure Invalidate; override;
+    procedure InvalidateRect(const aRect: TFresnelRect); override;
+    function HandlePaintMsg: LRESULT; virtual;
+    procedure HandleSizeMsg; virtual;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+
+    function CreateWSWindow: HWND; virtual;
+    procedure DestroyWSWindow; virtual;
+    property Window: HWND read FWindow;
+    property Form: TFresnelCustomForm read FForm write SetForm;
+  end;
+
+  { TWinApiWidgetSet }
+
+  TWinApiWidgetSet = class(TFresnelWidgetSet)
+  private
+    FFontEngine: TWinApiFontEngine;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure AppWaitMessage; override;
+    procedure AppProcessMessages; override;
+    procedure AppTerminate; override;
+    procedure AppSetTitle(const ATitle: string); override;
+
+    procedure CreateWSForm(aFresnelForm: TFresnelComponent); override;
+    property FontEngineWinApi: TWinApiFontEngine read FFontEngine;
+  end;
+
+type
+  TWinApiWindowInfo = record
+    Form: TWinApiWSForm;
+  end;
+  PWinApiWindowInfo = ^TWinApiWindowInfo;
+
+
+var
+  WinApiWidgetSet: TWinApiWidgetSet;
+  WindowInfoAtom: ATOM;
+  WindowInfoAtomStr: LPCSTR;
+
+implementation
+
+procedure CreateDrawBuffer(const aMemDC: HDC; const aWidth, aHeight: Integer;
+  out aBuffer: HBITMAP; out aData: Pointer; out aStride: Integer);
+const
+  {%H-}ColorMasks: array[0..2] of DWord = ($ff0000, $00ff00, $0000ff);
+var
+  aBitmapInfo: PBITMAPINFO;
+begin
+  aStride:=aWidth*4;
+  aBuffer:=0;
+  aData:=nil;
+  aBitmapInfo:=AllocMem(SizeOf(TBITMAPINFOHEADER));
+  try
+    with aBitmapInfo^.bmiHeader do
+    begin
+      biSize:=SizeOf(TBITMAPINFOHEADER);
+      biWidth:=aWidth;
+      biHeight:=-aHeight;
+      biPlanes:=1;
+      biBitCount:=32;
+      biCompression:=BI_BITFIELDS;
+      biSizeImage:=aStride*aHeight;
+    end;
+    System.Move(ColorMasks[0],aBitmapInfo^.bmiColors[0],SizeOf(ColorMasks));
+    aBuffer:=CreateDIBSection(aMemDC,aBitmapInfo,DIB_RGB_COLORS, @aData,0,0);
+    if aBuffer<>0 then
+      GdiFlush;
+  finally
+    Freemem(aBitmapInfo);
+  end;
+end;
+
+function AllocWindowInfo(Window: HWND): PWinApiWindowInfo;
+var
+  WindowInfo: PWinApiWindowInfo;
+begin
+  New(WindowInfo);
+  WindowInfo^ := Default(TWinApiWindowInfo);
+  Windows.SetProp(Window, WindowInfoAtomStr, {%H-}PtrUInt(WindowInfo));
+  Result := WindowInfo;
+end;
+
+function DisposeWindowInfo(Window: HWND): boolean;
+var
+  WindowInfo: PWinApiWindowInfo;
+begin
+  WindowInfo := {%H-}PWinApiWindowInfo(Windows.GetProp(Window, WindowInfoAtomStr));
+  Result := Windows.RemoveProp(Window, WindowInfoAtomStr) <> 0;
+  if Result then
+  begin
+    Dispose(WindowInfo);
+  end;
+end;
+
+function GetWinApiWindowInfo(Window: HWND): PWinApiWindowInfo;
+begin
+  Result := {%H-}PWinApiWindowInfo(Windows.GetProp(Window, WindowInfoAtomStr));
+end;
+
+function WindowProc(aHandle: HWND; aMsg: UINT; aWParam: WPARAM; aLParam: LPARAM): LRESULT; stdcall;
+var
+  XPos, YPos: LongInt;
+  aWndInfo: PWinApiWindowInfo;
+  aForm: TWinApiWSForm;
+begin
+  aWndInfo:=GetWinApiWindowInfo(aHandle);
+  if aWndInfo<>nil then
+  begin
+    aForm:=aWndInfo^.Form;
+
+    case aMsg of
+    WM_PAINT:
+      begin
+        Result:=aForm.HandlePaintMsg;
+        exit;
+      end;
+    WM_SIZE:
+      begin
+        InvalidateRect(aHandle,nil,false);
+        aForm.HandleSizeMsg;
+      end;
+    WM_KEYDOWN:
+      begin
+        writeln('KeyDown: ',aWParam);
+        if aWParam=VK_ESCAPE then
+          PostQuitMessage(0);
+        exit(0);
+      end;
+    WM_KEYUP:
+      begin
+        writeln('KeyUp: ',aWParam);
+        exit(0);
+      end;
+    WM_LBUTTONDOWN:
+      begin
+        XPos := GET_X_LPARAM(aLParam);
+        YPos := GET_Y_LPARAM(aLParam);
+        writeln('LButtonDown ',XPos,',',YPos);
+        exit(0);
+      end;
+    WM_CLOSE:
+      begin
+        PostQuitMessage(0);
+        exit(0);
+      end;
+    end;
+  end;
+
+  Result:=DefWindowProc(aHandle,aMsg,aWParam,aLParam);
+end;
+
+
+{ TWinApiWSForm }
+
+procedure TWinApiWSForm.SetForm(AValue: TFresnelCustomForm);
+begin
+  if FForm=AValue then Exit;
+  FForm:=AValue;
+  if FForm<>nil then
+    FreeNotification(FForm);
+end;
+
+procedure TWinApiWSForm.Notification(AComponent: TComponent; Operation: TOperation
+  );
+begin
+  inherited Notification(AComponent, Operation);
+  if Operation=opRemove then
+  begin
+    if FForm=AComponent then
+      FForm:=nil;
+  end;
+end;
+
+function TWinApiWSForm.GetFormBounds: TFresnelRect;
+var
+  r: TRect;
+begin
+  r:=Default(TRect);
+  if not GetWindowRect(FWindow,r) then
+    if Form<>nil then
+      r:=Form.FormBounds.GetRect;
+  Result.SetRect(r);
+end;
+
+function TWinApiWSForm.GetCaption: TFresnelCaption;
+begin
+  Result:='';
+  // todo: TWinApiWSForm.GetCaption
+  raise Exception.Create('TWinApiWSForm.GetCaption ToDo');
+end;
+
+function TWinApiWSForm.GetVisible: boolean;
+begin
+  // todo: TWinApiWSForm.GetVisible
+  Result:=true;
+end;
+
+procedure TWinApiWSForm.DeleteDrawBuffer;
+begin
+  if FDrawBuffer=0 then exit;
+  DeleteObject(FDrawBuffer);
+  FDrawBuffer:=0;
+  FDrawBufferData:=nil;
+end;
+
+function TWinApiWSForm.HandlePaintMsg: LRESULT;
+const
+  BlendFunction: TBlendFunction = (
+    BlendOp: AC_SRC_OVER;
+    BlendFlags: 0;
+    SourceConstantAlpha: 255;
+    AlphaFormat: AC_SRC_ALPHA
+    );
+var
+  ps: TPAINTSTRUCT;
+  dc, BufDC: HDC;
+  r: TRect;
+  OldBmp: HGDIOBJ;
+  SkSurface: ISkSurface;
+  SkCanvas: ISkCanvas;
+  W, H: LongInt;
+  SkiaRenderer: TFresnelSkiaRenderer;
+begin
+  r:=Default(TRect);
+  GetClientRect(FWindow,r);
+  W:=r.Width;
+  H:=r.Height;
+  if (W<=0) or (H<=0) then exit;
+
+  ps:=Default(TPAINTSTRUCT);
+  dc:=BeginPaint(FWindow,ps);
+  try
+    BufDC:=CreateCompatibleDC(0);
+    if BufDC=0 then exit;
+    OldBmp:=0;
+    try
+      if (FDrawBuffer>0)
+          and ((FDrawBufferSize.Width<>W) or (FDrawBufferSize.Height<>H)) then
+        DeleteDrawBuffer;
+      if FDrawBuffer=0 then
+        CreateDrawBuffer(BufDC,W,H,
+                         FDrawBuffer,FDrawBufferData,FDrawBufferStride);
+      if FDrawBuffer=0 then
+        exit;
+      OldBmp:=SelectObject(BufDC,FDrawBuffer);
+      {$IFDEF FresnelSkia}
+      if Form.Renderer is TFresnelSkiaRenderer then
+      begin
+        SkiaRenderer:=TFresnelSkiaRenderer(Form.Renderer);
+        try
+          SkSurface:=TSkSurface.MakeRasterDirect(TSkImageInfo.Create(W,H),
+            FDrawBufferData,FDrawBufferStride);
+          SkCanvas:=SkSurface.Canvas;
+          SkiaRenderer.Canvas:=SkCanvas;
+
+          Form.WSDraw;
+
+          AlphaBlend(dc,0,0,r.Width,r.Height,BufDC,0,0,W,H,BlendFunction);
+
+        finally
+          SkiaRenderer.Canvas:=nil;
+        end;
+      end;
+      {$ENDIF}
+    finally
+      if OldBmp<>0 then
+        SelectObject(BufDC,OldBmp);
+      DeleteDC(BufDC);
+    end;
+  finally
+    EndPaint(FWindow,ps);
+  end;
+  Result:=0;
+end;
+
+procedure TWinApiWSForm.RegisterWindowClass(const aClassName: PChar);
+var
+  wc: TWNDCLASS;
+begin
+  wc:=Default(TWNDCLASS);
+  wc.lpfnWndProc:=@WindowProc;
+  wc.hInstance:=HINSTANCE;
+  wc.hbrBackground:=GetStockObject(WHITE_BRUSH);
+  wc.lpszClassName:=aClassName;
+  wc.hCursor:=LoadCursor(0,IDC_ARROW);
+  RegisterClass(wc);
+end;
+
+procedure TWinApiWSForm.SetFormBounds(const AValue: TFresnelRect);
+var
+  r: TRect;
+begin
+  r:=AValue.GetRect;
+  if not SetWindowPos(FWindow,0,r.Left,r.Top,r.Width,r.Height,0) then
+  begin
+    // todo: handle TWinApiWSForm.SetFormBounds failed
+  end;
+end;
+
+procedure TWinApiWSForm.SetCaption(AValue: TFresnelCaption);
+begin
+  // todo: TWinApiWSForm.SetCaption
+  if AValue='' then ;
+end;
+
+procedure TWinApiWSForm.SetVisible(const AValue: boolean);
+var
+  CmdShow: longint;
+begin
+  if AValue then
+    CmdShow:=SW_SHOW
+  else
+    CmdShow:=SW_HIDE;
+  ShowWindow(FWindow,CmdShow);
+end;
+
+function TWinApiWSForm.GetClientSize: TFresnelPoint;
+var
+  r: TRect;
+begin
+  r:=Default(TRect);
+  GetClientRect(FWindow,r);
+  Result.X:=r.Width;
+  Result.Y:=r.Height;
+end;
+
+procedure TWinApiWSForm.Invalidate;
+begin
+  Windows.InvalidateRect(FWindow,nil,true);
+end;
+
+procedure TWinApiWSForm.InvalidateRect(const aRect: TFresnelRect);
+begin
+  Windows.InvalidateRect(FWindow,aRect.GetRect,true);
+end;
+
+procedure TWinApiWSForm.HandleSizeMsg;
+var
+  aFormRect, aClientRect: TRect;
+  FreRect: TFresnelRect;
+begin
+  aFormRect:=Default(TRect);
+  if not GetWindowRect(FWindow,aFormRect) then
+    exit;
+  if (aFormRect.Width<=0) or (aFormRect.Height<=0) then exit;
+
+  aClientRect:=Default(TRect);
+  if not GetClientRect(FWindow,aClientRect) then
+    exit;
+  if (aClientRect.Right<=0) or (aClientRect.Bottom<=0) then exit;
+
+  FreRect.SetRect(aFormRect);
+  Form.WSResize(FreRect,aClientRect.Right,aClientRect.Bottom);
+end;
+
+constructor TWinApiWSForm.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  SetRenderer(TWinApiRenderer.Create(Self));
+end;
+
+destructor TWinApiWSForm.Destroy;
+begin
+  SetRenderer(Nil);
+  DestroyWSWindow;
+
+  inherited Destroy;
+end;
+
+function TWinApiWSForm.CreateWSWindow: HWND;
+const
+  // todo: create unique classname
+  aClassName = 'FresnelWindow';
+var
+  aRect: TRect;
+  Info: PWinApiWindowInfo;
+begin
+  aRect:=Form.FormBounds.GetRect;
+
+  RegisterWindowClass(aClassName);
+  FWindow:= CreateWindowEx(0,aClassName,'FormTitle',
+    WS_OVERLAPPEDWINDOW,
+    aRect.Left,aRect.Top,aRect.Width,aRect.Height, 0,0, HINSTANCE, nil);
+  Result:=FWindow;
+  Info:=AllocWindowInfo(FWindow);
+  Info^.Form:=Self;
+
+  ShowWindow(FWindow,SW_SHOW);
+end;
+
+procedure TWinApiWSForm.DestroyWSWindow;
+begin
+  if FWindow=0 then exit;
+  DisposeWindowInfo(FWindow);
+  //  todo: TWinApiWSForm.DestroyWSWindow
+end;
+
+{ TWinApiWidgetSet }
+
+constructor TWinApiWidgetSet.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+
+  WinApiWidgetSet:=Self;
+  FWSFormClass:=TWinApiWSForm;
+
+  FFontEngine:=TWinApiFontEngine.Create(nil);
+  TFresnelFontEngine.WSEngine:=FFontEngine;
+end;
+
+destructor TWinApiWidgetSet.Destroy;
+begin
+  TFresnelFontEngine.WSEngine:=nil;
+  FreeAndNil(FFontEngine);
+  WinApiWidgetSet:=nil;
+  inherited Destroy;
+end;
+
+procedure TWinApiWidgetSet.AppWaitMessage;
+var
+  aWaitHandleCount, timeout, retVal: DWORD;
+  pHandles: Windows.LPHANDLE;
+begin
+  writeln('TWinApiWidgetSet.AppWaitMessage START');
+  aWaitHandleCount:=0;
+  pHandles:=nil;
+  timeout := INFINITE;
+  retVal := Windows.MsgWaitForMultipleObjects(aWaitHandleCount, pHandles,
+    false, timeout, QS_ALLINPUT);
+  writeln('TWinApiWidgetSet.AppWaitMessage END ',retVal);
+end;
+
+procedure TWinApiWidgetSet.AppProcessMessages;
+var
+  aMessage: TMsg;
+begin
+  writeln('TWinApiWidgetSet.AppProcessMessages START');
+  AMessage := Default(TMsg);
+  while PeekMessage(AMessage, 0, 0, 0, PM_REMOVE) do
+  begin
+    if AMessage.message = WM_QUIT then
+    begin
+      PostQuitMessage(AMessage.wParam);
+      AppTerminate;
+      break;
+    end;
+    TranslateMessage(aMessage);
+    DispatchMessage(aMessage);
+  end;
+  writeln('TWinApiWidgetSet.AppProcessMessages END');
+end;
+
+procedure TWinApiWidgetSet.AppTerminate;
+begin
+  Application.Terminate;
+end;
+
+procedure TWinApiWidgetSet.AppSetTitle(const ATitle: string);
+begin
+  if ATitle='' then ;
+  //if FAppHandle <> 0 then
+  //begin
+  //  ws:=ATitle;
+    // todo: TWinApiWidgetSet.AppSetTitle
+    //Windows.SetWindowTextW(FAppHandle, PWideChar(ws));
+  //end;
+end;
+
+procedure TWinApiWidgetSet.CreateWSForm(aFresnelForm: TFresnelComponent);
+var
+  aForm: TFresnelCustomForm;
+  aWSForm: TWinApiWSForm;
+begin
+  if not (aFresnelForm is TFresnelCustomForm) then
+    raise Exception.Create('TWinApiWidgetSet.CreateWSForm '+aFresnelForm.ToString);
+  aForm:=TFresnelCustomForm(aFresnelForm);
+  aForm.FontEngine:=FontEngineWinApi;
+
+  aWSForm:=TWinApiWSForm.Create(aForm);
+  aWSForm.Form:=aForm;
+  aForm.WSForm:=aWSForm;
+  aWSForm.CreateWSWindow;
+end;
+
+initialization
+  WindowInfoAtom := Windows.GlobalAddAtom('WindowInfo');
+  WindowInfoAtomStr:={%H-}lpcstr(PtrUint(WindowInfoAtom));
+  TWinApiWidgetSet.Create(nil);
+
+finalization
+  Windows.GlobalDeleteAtom(WindowInfoAtom);
+  WindowInfoAtom := 0;
+  WindowInfoAtomStr:=nil;
+  WinApiWidgetSet.Free; // it will nil itself
+
+end.
+