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

LCLExtensions/include/gtk2/delphicompat.inc

@@ -0,0 +1,394 @@
+{ 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.
+
+}
+
+{$MACRO ON}
+{$if lcl_fullversion > 1000000}
+{$define TGtk2DeviceContext:=TGtkDeviceContext}
+{$endif}
+
+{$define HAS_INVERTRECT}
+{$define HAS_DRAWTEXTW}
+{$define HAS_GETCURRENTOBJECT}
+{$define HAS_GETBKCOLOR}
+{$define HAS_GETTEXTEXTENTEXPOINT}
+{$define HAS_SCROLLWINDOW}
+
+{$i ../generic/stubs.inc}
+{$i ../generic/independentfunctions.inc}
+{$i ../generic/unicodefunctions.inc}
+
+
+procedure pango_extents_to_pixels (ink_rect: PPangoRectangle;
+			  logical_rect: PPangoRectangle); cdecl; external 'libpango-1.0.so.0';
+
+function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
+  YSrc: Integer; Rop: DWORD): Boolean;
+begin
+  Result := GTK2WidgetSet.StretchCopyArea(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
+   0, XSrc, YSrc, Rop);
+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 GTK2WidgetSet.IsValidDC(DC) then
+    Result := TGtkDeviceContext(DC).CurrentBackColor.ColorRef
+  else
+    Result := CLR_INVALID;
+end;
+
+function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
+begin
+  Result := 0;
+  if GTK2WidgetSet.IsValidDC(hdc) then
+  with TGtk2DeviceContext(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: PInteger;
+  var Size: TSize): BOOL;
+var
+  layout: PPangoLayout;
+  i: Integer;
+  Rect: TPangoRectangle;
+  iter : PPangoLayoutIter;
+begin
+  Result := GTK2WidgetSet.IsValidDC(DC);
+  if Result then
+  with TGtk2DeviceContext(DC) do
+  begin
+    if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then
+      layout := GTK2WidgetSet.GetDefaultGtkFont(false)
+    else
+      layout := CurrentFont^.GDIFontObject;
+    pango_layout_set_text(layout, Str, Count);
+    if PartialWidths = nil then
+      pango_layout_get_pixel_size (layout, @Size.cx, @Size.cy)
+    else
+      begin
+        i := 0;
+        Size.cx := 0;
+        Size.cy := 0;
+        iter := pango_layout_get_iter(layout);
+        repeat
+          pango_layout_iter_get_char_extents(iter,@Rect);
+          pango_extents_to_pixels(nil,@Rect);
+          inc(Size.cx, Rect.Width);
+          PartialWidths[i] := Size.cx;
+          if Size.cy < Rect.Height then
+            Size.cy := Rect.Height;
+          inc(i);
+        until not pango_layout_iter_next_char(iter);
+        pango_layout_iter_free(iter);
+      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 := GTK2WidgetSet.IsValidDC(DC) and (lprc.Bottom > lprc.Top)
+    and (lprc.Right > lprc.Left);
+  if Result then
+  begin
+    with TGtk2DeviceContext(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._function);
+    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
+
+  TTimerID = record
+    hWnd: THandle;
+    nIDEvent: UINT_PTR;
+  end;
+
+  { TGtk2Timer }
+
+  TGtk2Timer = class
+  private
+    FControl: TControl;
+    FNotify: TTimerNotify;
+    FId: UINT_PTR;
+    FHandle: THandle;
+    FTimerHandle: guint;
+  public
+    constructor Create(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify);
+    procedure Start(Interval: LongWord);
+    procedure Stop;
+  end;
+
+  { TTimerList }
+
+  TTimerList = class
+  private
+    FMap: TMap;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure Delete(hWnd: THandle; nIDEvent: UINT_PTR);
+    function Find(hWnd: THandle; nIDEvent: UINT_PTR): TGtk2Timer;
+    function Get(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify): TGtk2Timer;
+  end;
+
+var
+  FTimerList: TTimerList;
+
+function gtkWidgetDestroyCB(Widget: PGtkWidget; Timer: TGtk2Timer): GBoolean; cdecl;
+begin
+  Result := GdkFalse;
+  Timer.Stop;
+  FTimerList.Delete(Timer.FHandle, Timer.FId);
+  Timer.Destroy;
+end;
+
+function gtkTimerCB(Timer: TGtk2Timer): gBoolean; cdecl;
+begin
+  Result := GdkFalse;  // assume: timer will stop
+  //DebugLn('gtkTimerCalled for TimerHandle: %d',[TimerHandle]);
+  if Timer.FNotify <> nil then
+  begin
+    Timer.FNotify(Timer.FId);
+    Result := GdkTrue;
+  end
+  else
+  begin
+    if Timer.FControl <> nil then
+    begin
+      LCLSendTimerMsg(Timer.FControl, Timer.FId, 0);
+      Result := GdkTrue;
+    end;
+  end;
+end;
+
+{ TGtk2TimerInfo }
+
+constructor TGtk2Timer.Create(hWnd: THandle; nIDEvent: UINT_PTR;
+  NotifyFunc: TTimerNotify);
+begin
+  //todo: make a custom GetLCLObject
+  if hWnd <> 0 then
+  begin
+    FControl := TControl(GetLCLObject(PGtkWidget(hWnd)));
+    g_signal_connect(PGObject(hWnd), 'destroy', gtk_Signal_Func(@gtkWidgetDestroyCB), Self);
+  end
+  else
+    FControl := nil;
+  FHandle := hWnd;
+  FId := nIDEvent;
+  FNotify := NotifyFunc;
+end;
+
+procedure TGtk2Timer.Start(Interval: LongWord);
+begin
+  //restart
+  if FTimerHandle <> 0 then
+    g_source_remove(FTimerHandle);
+  FTimerHandle := g_timeout_add(Interval, TGSourceFunc(@gtkTimerCB), Self);
+end;
+
+procedure TGtk2Timer.Stop;
+begin
+  if FTimerHandle <> 0 then
+  begin
+    g_source_remove(FTimerHandle);
+    FTimerHandle := 0;
+  end;
+end;
+
+{ TTimerList }
+
+constructor TTimerList.Create;
+begin
+  FMap := TMap.Create({$ifdef CPU64}itu16{$else}itu8{$endif}, SizeOf(TGtk2Timer));
+end;
+
+destructor TTimerList.Destroy;
+var
+  Iterator: TMapIterator;
+  TimerInfo: TGtk2Timer;
+begin
+  Iterator := TMapIterator.Create(FMap);
+  with Iterator do
+  begin
+    while not EOM do
+    begin
+      GetData(TimerInfo);
+      TimerInfo.Free;
+      Next;
+    end;
+    Destroy;
+  end;
+  FMap.Destroy;
+end;
+
+procedure TTimerList.Delete(hWnd: THandle; nIDEvent: UINT_PTR);
+var
+  TimerID: TTimerID;
+begin
+  TimerID.hWnd := hWnd;
+  TimerID.nIDEvent := nIDEvent;
+  FMap.Delete(TimerID);
+end;
+
+function TTimerList.Get(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify): TGtk2Timer;
+var
+  TimerID: TTimerID;
+begin
+  TimerID.hWnd := hWnd;
+  TimerID.nIDEvent := nIDEvent;
+  with FMap do
+  begin
+    if HasId(TimerID) then
+    begin
+      // DebugLn('Reset timer for HWnd: %d ID: %d AID: %d', [hWnd, ID, TimerID]);
+      GetData(TimerID, Result);
+      Result.FNotify := NotifyFunc;
+    end
+    else
+    begin
+      // DebugLn('Create timer for HWnd: %d ID: %d AID: %d', [hWnd, ID, TimerID]);
+      Result := TGtk2Timer.Create(hWnd, nIDEvent, NotifyFunc);
+      if hWnd = 0 then
+      begin
+        TimerID.nIDEvent := PtrUInt(Result);
+        Result.FId := PtrUInt(Result);
+      end;
+      Add(TimerID, Result);
+    end;
+  end;
+end;
+
+function TTimerList.Find(hWnd: THandle; nIDEvent: UINT_PTR): TGtk2Timer;
+var
+  DataPtr: ^TGtk2Timer;
+  TimerID: TTimerID;
+begin
+  Result := nil;
+  TimerID.hWnd := hWnd;
+  TimerID.nIDEvent := nIDEvent;
+  // DebugLn('GetTimerInfo for HWnd: %d ID: %d AID: %d', [hWnd, ID, TimerID]);
+  DataPtr := FMap.GetDataPtr(TimerID);
+  if DataPtr <> nil then
+    Result := DataPtr^;
+end;
+
+function SetTimer(hWnd: THandle; nIDEvent: UINT_PTR; uElapse: LongWord; lpTimerFunc: TTimerNotify): UINT_PTR;
+var
+  Timer: TGtk2Timer;
+begin
+  Timer := FTimerList.Get(hWnd, nIDEvent, lpTimerFunc);
+  try
+    Timer.Start(uElapse);
+    if hWnd = 0 then
+      Result := PtrUInt(Timer)
+    else
+      Result := nIdEvent;
+  except
+    Result := 0;
+  end;
+  //DebugLn('SetTimer HWnd: %d ID: %d TimerHandle: %d',[hWnd,nIDEvent,Timer.FTimerHandle]);
+end;
+
+function KillTimer(hWnd:THandle; nIDEvent: UINT_PTR): Boolean;
+var
+  Timer: TGtk2Timer;
+begin
+  //todo: investigate how to set result
+  Result := True;
+  Timer := FTimerList.Find(hWnd, nIDEvent);
+  //DebugLn('KillTimer HWnd: %d ID: %d TimerHandle: %d',[hWnd,nIDEvent,Timer^.TimerHandle]);
+  if Timer <> nil then
+    Timer.Stop;
+end;
+
+
+

LCLExtensions/include/gtk2/lclext.inc

@@ -0,0 +1,22 @@
+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 := GTK2WidgetSet.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/gtk2/uses.inc

@@ -0,0 +1,2 @@
+
+  LCLIntf, Graphics, Gtk2Def, gdk2, gtk2, Gtk2Proc, Gtk2Int, pango, glib2, math,

LCLExtensions/include/gtk2/uses_lclext.inc

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