Стартовый пул

LCLExtensions/include/gtk/delphicompat.inc

@@ -0,0 +1,336 @@
+
+{ This file is part of Delphi Compatibility Unit
+
+  Copyright (C) 2007 Luiz Américo Pereira Câmara
+  pascalive@bol.com.br
+
+  This library is free software; you can redistribute it and/or modify it
+  under the terms of the GNU Library General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or (at your
+  option) any later version with the following modification:
+
+  As a special exception, the copyright holders of this library give you
+  permission to link this library with independent modules to produce an
+  executable, regardless of the license terms of these independent modules,and
+  to copy and distribute the resulting executable under terms of your choice,
+  provided that you also meet, for each linked independent module, the terms
+  and conditions of the license of that module. An independent module is a
+  module which is not derived from or based on this library. If you modify
+  this library, you may extend this exception to your version of the library,
+  but you are not obligated to do so. If you do not wish to do so, delete this
+  exception statement from your version.
+
+  This program is distributed in the hope that it will be useful, but WITHOUT
+  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+  for more details.
+
+  You should have received a copy of the GNU Library General Public License
+  along with this library; if not, write to the Free Software Foundation,
+  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+}
+
+{$define HAS_INVERTRECT}
+{$define HAS_DRAWTEXTW}
+{$define HAS_GETCURRENTOBJECT}
+{$define HAS_GETBKCOLOR}
+{$define HAS_GETTEXTEXTENTEXPOINT}
+{$define HAS_DRAWFRAMECONTROL}
+{$define HAS_SCROLLWINDOW}
+
+{$i ../generic/stubs.inc}
+{$i ../generic/independentfunctions.inc}
+{$i ../generic/unicodefunctions.inc}
+
+function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
+  YSrc: Integer; Rop: DWORD): Boolean;
+begin
+  Result := GTKWidgetSet.StretchCopyArea(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
+   0, XSrc, YSrc, Rop);
+end;
+
+function DrawFrameControl(DC: HDC; const Rect: TRect; uType, uState: LongWord): Boolean;
+begin
+  Result := LCLIntf.DrawFrameControl(DC, Rect, uType, uState);
+end;
+
+function DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; var lpRect: TRect; uFormat: LongWord): Integer;
+var
+  TempStr: UTF8String;
+  TempRect: TRect;
+  TextHeight: Integer;
+  TM: TTextMetric;
+begin
+  //Logger.Send('DrawTextW');
+  TempRect := lpRect;
+  //fix position under gtk (lcl bug 8565)
+  if (uFormat and DT_VCENTER) > 0 then
+  begin
+    GetTextMetrics(hDC, TM);
+    //gtk overestimate height
+    TextHeight := TM.tmHeight - 2;
+    TempRect.Top := (TempRect.Top + TempRect.Bottom - TextHeight) div 2;
+  end;
+  TempStr := UTF8Encode(WideString(lpString));
+  Result := DrawText(hDC, PChar(TempStr), GetUTF8ByteCount(TempStr, nCount),
+    TempRect, uFormat);
+  //Logger.Send('Rect',TempRect);
+end;
+
+function GetBkColor(DC:HDC):COLORREF;
+begin
+  if GTKWidgetSet.IsValidDC(DC) then
+    Result := TGtkDeviceContext(DC).CurrentBackColor.ColorRef
+  else
+    Result := CLR_INVALID;
+end;
+
+function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
+begin
+  Result := 0;
+  if GTKWidgetSet.IsValidDC(hdc) then
+  with TGtkDeviceContext(hdc) do
+  begin
+    case uObjectType of
+      OBJ_BITMAP: Result := HGDIOBJ(CurrentBitmap);
+      OBJ_BRUSH: Result := HGDIOBJ(CurrentBrush);
+      OBJ_FONT: Result := HGDIOBJ(CurrentFont);
+      OBJ_PEN: Result := HGDIOBJ(CurrentPen);
+    end;
+  end;
+end;
+
+function GetTextExtentExPoint(DC: HDC; Str: PChar; Count, MaxWidth: Integer;
+  MaxCount, PartialWidths: ObjPas.PInteger; var Size: TSize): BOOL;
+var
+  lbearing, rbearing, width, ascent,descent: LongInt;
+  UseFont : PGDKFont;
+  IsDBCSFont: Boolean;
+  NewCount,Accumulator,i: Integer;
+begin
+  //based in lcl code
+  Result := GTKWidgetSet.IsValidDC(DC);
+  if Result then
+  with TGtkDeviceContext(DC) do
+  begin
+    if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil)
+    then begin
+      UseFont := GTKWidgetSet.GetDefaultGtkFont(false);
+    end
+    else begin
+      UseFont := CurrentFont^.GDIFontObject;
+    end;
+    If UseFont = nil then
+      DebugLn('WARNING: [TGtkWidgetSet.GetTextExtentPoint] Missing font')
+    else begin
+      descent:=0;
+      {
+      UpdateDCTextMetric(TDeviceContext(DC));
+      IsDBCSFont:=TDeviceContext(DC).DCTextMetric.IsDoubleByteChar;
+
+      if IsDBCSFont then begin
+        NewCount:=Count*2;
+        if FExtUTF8OutCacheSize<NewCount then begin
+          ReAllocMem(FExtUTF8OutCache,NewCount);
+          FExtUTF8OutCacheSize:=NewCount;
+        end;
+        NewCount:=UTF8ToDoubleByte(Str,Count,FExtUTF8OutCache)*2;
+        gdk_text_extents(UseFont, FExtUTF8OutCache, NewCount,
+                         @lbearing, @rBearing, @width, @ascent, @descent);
+      end else begin
+        gdk_text_extents(UseFont, Str, Count,
+                         @lbearing, @rBearing, @width, @ascent, @descent);
+      end;
+      }
+      gdk_text_extents(UseFont, Str, Count,@lbearing, @rBearing, @width, @ascent, @descent);
+      Size.cX := Width;
+      Size.cY := ascent+descent;
+      if PartialWidths <> nil then
+      begin
+        Accumulator:=0;
+        for i:= 0 to Count - 1 do
+        begin
+          Inc(Accumulator,gdk_char_width(UseFont,(Str+i)^));
+          PartialWidths[i]:=Accumulator;
+        end;
+      end;
+    end;
+  end;
+end;
+
+function InvertRect(DC: HDC; const lprc: TRect): Boolean;
+var
+  DCOrigin: TPoint;
+  Values: TGdkGCValues;
+begin
+  //todo: see the windows result when rect is invalid
+  Result := GTKWidgetSet.IsValidDC(DC) and (lprc.Bottom > lprc.Top)
+    and (lprc.Right > lprc.Left);
+  if Result then
+  begin
+    with TGtkDeviceContext(DC) do
+    begin
+      DCOrigin := Offset;
+      //todo: see if is necessary store old function
+      gdk_gc_get_values(GC, @Values);
+      gdk_gc_set_function(GC,GDK_INVERT);
+      gdk_draw_rectangle(Drawable,GC,1,
+        DCOrigin.X + lprc.Left, DCOrigin.Y + lprc.Top,
+        lprc.Right - lprc.Left, lprc.Bottom - lprc.Top);
+      gdk_gc_set_function(GC,Values.thefunction);
+    end;
+  end;
+end;
+
+function ScrollWindow(hWnd:THandle; XAmount, YAmount:longint;lpRect:PRECT; lpClipRect:PRECT):Boolean;
+begin
+  //gtk implementation does nothing if lpRect and lpClipRect are not nil
+  Result := LCLIntf.ScrollWindowEx(hWnd, XAmount, YAmount, nil, nil, 0, nil, SW_INVALIDATE);
+end;
+
+var
+  CachedUnicodeFormat: TClipboardFormat;
+  
+function CF_UNICODETEXT: TClipboardFormat;
+begin
+  //todo: see what mime type gtk expects for utf16
+  if CachedUnicodeFormat = 0 then
+    CachedUnicodeFormat:= gdk_atom_intern('text/utf16',GdkFalse);
+  Result := CachedUnicodeFormat;
+end;
+
+type
+  TTimerRecord = record
+    Control: TControl;
+    Notify: TTimerNotify;
+    Id: LongWord;
+    TimerHandle: guint;
+  end;
+  PTimerRecord = ^TTimerRecord;
+
+  { TTimerList }
+
+  TTimerList = class
+  private
+    FList: TMap;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    function Add(hWnd: THandle; ID: LongWord; NotifyFunc: TTimerNotify; WinControl: TControl):PTimerRecord;
+    function GetTimerInfo(Handle: hWnd; idEvent:LongWord; out TimerInfo: TTimerRecord):Boolean;
+    function GetTimerInfoPtr(Handle: hWnd; idEvent:LongWord): PTimerRecord;
+  end;
+
+var
+  FTimerList: TTimerList;
+
+function MakeQWord(d1, d2: dword): QWord; inline;
+begin
+  Result:=(QWord(d2) shl 32) or d1;
+end;
+
+{ TTimerList }
+
+constructor TTimerList.Create;
+begin
+  //todo: see 64bit (itu16??)
+  FList:=TMap.Create(itu8,SizeOf(TTimerRecord));
+end;
+
+destructor TTimerList.Destroy;
+begin
+  FList.Destroy;
+  inherited Destroy;
+end;
+
+function TTimerList.Add(hWnd: THandle; ID: LongWord; NotifyFunc: TTimerNotify; WinControl: TControl):PTimerRecord;
+var
+  AID: QWord;
+  ATimerRec: TTimerRecord;
+begin
+  ATimerRec.Notify := NotifyFunc;
+  ATimerRec.Control := WinControl;
+  ATimerRec.Id := ID;
+  AId:=MakeQWord(hWnd,ID);
+  with FList do
+  begin
+    if HasId(AID) then
+      SetData(AID, ATimerRec)
+    else
+      Add(AID, ATimerRec);
+    Result := GetDataPtr(AID);
+  end;
+end;
+
+function TTimerList.GetTimerInfo(Handle: hWnd; idEvent: LongWord; out
+  TimerInfo: TTimerRecord): Boolean;
+begin
+  Result:= FList.GetData(MakeQWord(Handle,idEvent),TimerInfo);
+end;
+
+function TTimerList.GetTimerInfoPtr(Handle: hWnd; idEvent: LongWord
+  ): PTimerRecord;
+begin
+  Result := FList.GetDataPtr(MakeQWord(Handle,idEvent));
+end;
+
+function gtkTimerCB(Data: gPointer): {$IFDEF Gtk2}gBoolean{$ELSE}gint{$ENDIF}; cdecl;
+begin
+  Result := GdkFalse;  // assume: timer will stop
+  with PTimerRecord(Data)^ do
+  begin
+    //DebugLn('gtkTimerCalled for TimerHandle: %d',[TimerHandle]);
+    if TimerHandle <> 0 then
+    begin
+      if Notify <> nil then
+      begin
+        Notify(Id);
+        Result := GdkTrue;
+      end
+      else
+      begin
+        if Control <> nil then
+        begin
+          LCLSendTimerMsg(Control,Id,0);
+          Result := GdkTrue;
+        end;
+      end;
+    end;
+  end;
+end;
+
+function SetTimer(hWnd:THandle; nIDEvent:LongWord; uElapse:LongWord; lpTimerFunc:TTimerNotify):LongWord;
+var
+  TimerInfo: PTimerRecord;
+  Control: TControl;
+begin
+  //todo: properly set Result
+  //todo: make a custom GetLCLObject
+  if hWnd <> 0 then
+    Control := TControl(GetLCLObject(PGtkWidget(hWnd)))
+  else
+    Control := nil;
+  TimerInfo := FTimerList.Add(hWnd, nIDEvent, lpTimerFunc, Control);
+  TimerInfo^.TimerHandle := gtk_timeout_add(uElapse, @gtkTimerCB, TimerInfo);
+  //DebugLn('SetTimer HWnd: %d ID: %d TimerHandle: %d',[hWnd,nIDEvent,TimerInfo^.TimerHandle]);
+end;
+
+function KillTimer(hWnd:THandle; nIDEvent: LongWord):Boolean;
+var
+  TimerInfo: PTimerRecord;
+begin
+  TimerInfo := FTimerList.GetTimerInfoPtr(hWnd,nIDEvent);
+  if TimerInfo <> nil then
+  begin
+    //DebugLn('KillTimer HWnd: %d ID: %d TimerHandle: %d',[hWnd,nIDEvent,TimerInfo^.TimerHandle]);
+    gtk_timeout_remove(TimerInfo^.TimerHandle);
+    //next time gtkTimerCB be called the timeout will be destroied automatically
+    //todo: see if is really necessary to set TimerHandle to 0 and check in gtkTimerCB
+    TimerInfo^.TimerHandle := 0;
+  end;
+  //else
+  //  DebugLn('KillTimer Could not find the timer info of HWnd: %d ID: %d',[hWnd,nIDEvent]);
+end;
+
+

LCLExtensions/include/gtk/lclext.inc

@@ -0,0 +1,24 @@
+
+
+function CreateBitmapMask(BitmapDC: HDC; Width, Height: Integer; TransparentColor: TColor): HBITMAP;
+begin
+  //todo
+  Result := 0;
+end;
+
+function DirectMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP): Boolean;
+begin
+  //todo: see if is possible todo it faster
+  Result := GTKWidgetSet.StretchCopyArea(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
+   Mask, XSrc, YSrc,  SRCCOPY);
+end;
+
+function OptimalPixelFormat: TPixelFormat;
+begin
+  Result := pfDevice;
+end;
+
+function OSSupportsUTF16: Boolean;
+begin
+  Result := False;
+end;

LCLExtensions/include/gtk/uses.inc

@@ -0,0 +1,3 @@
+
+  LCLIntf, Graphics, gtkdef, gdk, GTKProc, GtkInt, glib, gtk, Math,
+

LCLExtensions/include/gtk/uses_lclext.inc

@@ -0,0 +1,2 @@
+uses
+  GtkInt;