pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

adds lazextensions since virtualtreeview depends on it

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3535 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
sekelsenmat
2014-09-10 12:46:38 +00:00
parent e277e09850
commit cbcff73171
37 changed files with 3065 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

168
components/lclextensions/delphicompat.pas Executable file
View File

@ -0,0 +1,168 @@
unit DelphiCompat;
{ 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.
}
{$mode objfpc}{$H+}
{.$define DEBUG_DELPHICOMPAT}
interface
uses
LMessages, Types, Classes, LCLType, LCLVersion;
const
//Messages
WM_GETDLGCODE = LM_GETDLGCODE;
WM_ERASEBKGND = LM_ERASEBKGND;
WM_VSCROLL = LM_VSCROLL;
WM_HSCROLL = LM_HSCROLL;
WM_CHAR = LM_CHAR;
WM_KEYDOWN = LM_KEYDOWN;
WM_KEYUP = LM_KEYUP;
WM_KILLFOCUS = LM_KILLFOCUS;
WM_SIZE = LM_SIZE;
WM_LBUTTONDBLCLK = LM_LBUTTONDBLCLK;
WM_LBUTTONDOWN = LM_LBUTTONDOWN;
type
//TWM* types
TMessage = TLMessage;
TWMHScroll = TLMHScroll;
TWMVScroll = TLMVScroll;
TWMChar = TLMChar;
TWMKeyDown = TLMKeyDown;
TWMKeyUp = TLMKeyUp;
TWMKillFocus = TLMKillFocus;
TWMSize = TLMSize;
TWMLButtonDblClk = TLMLButtonDblClk;
TWMMeasureItem = TLMMeasureItem;
TWMDrawItem = TLMDrawItems;
//timer
TTimerNotify = procedure (TimerId: PtrUInt) of object;
function BeginDeferWindowPos(nNumWindows: LongInt):THandle;
function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
function CF_UNICODETEXT: TClipboardFormat;
function CopyImage(hImage: THandle; uType:LongWord; cxDesired, cyDesired: LongInt; fuFlags:LongWord):THandle;
function DeferWindowPos(hWinPosInfo, hWnd, hWndInsertAfter:THandle; x, y, cx, cy:longint; uFlags:LongWord):THandle;
function DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; var lpRect: TRect; uFormat: LongWord): Integer;
function EndDeferWindowPos(hWinPosInfo:THandle):Boolean;
function ExtTextOutW(DC: HDC; X, Y: Integer; Options: LongInt; Rect: PRect;
Str: PWideChar; Count: LongInt; Dx: PInteger): Boolean;
function GdiFlush: Boolean;
function GetACP:LongWord;
function GetBkColor(DC:HDC):COLORREF;
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
function GetDCEx(hWnd:THandle; hrgnClip:HRGN; flags:DWORD):HDC;
function GetDoubleClickTime: UINT;
function GetKeyboardLayout(dwLayout:DWORD):THandle;
function GetKeyboardState(lpKeyState:PBYTE):BOOLEAN;
function GetLocaleInfo(Locale, LCType:LongWord; lpLCData:PChar; cchData:longint):longint;
function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall;
function GetTextAlign(hDC:HDC): LongWord;
function GetTextExtentExPoint(DC: HDC; Str: PChar;
Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger;
var Size: TSize): BOOL;
function GetTextExtentExPointW(DC: HDC; Str: PWideChar; Count, MaxWidth: Integer;
MaxCount, PartialWidths: PInteger; var Size: TSize): BOOL;
function GetTextExtentPoint32W(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
function GetTextExtentPointW(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
function GetWindowDC(hWnd:THandle):HDC;
function ImageList_DragShowNolock(fShow: Boolean): Boolean;
function InvertRect(DC: HDC; const lprc: TRECT): Boolean;
function KillTimer(hWnd:THandle; nIDEvent:UINT_PTR):Boolean;
function MapWindowPoints(hWndFrom, hWndTo: HWND; var lpPoints; cPoints: UINT): Integer;
function MultiByteToWideChar(CodePage, dwFlags:DWORD; lpMultiByteStr:PChar; cchMultiByte:longint; lpWideCharStr:PWideChar;cchWideChar:longint):longint;
function OffsetRgn(hrgn:HRGN; nxOffset, nYOffset:longint):longint;
function RedrawWindow(hWnd:THandle; lprcUpdate:PRECT; hrgnUpdate:HRGN; flags:LongWord): Boolean;
function ScrollDC(DC:HDC; dx:longint; dy:longint; var lprcScroll:TRECT; var lprcClip:TRECT;hrgnUpdate:HRGN; lprcUpdate:PRECT):Boolean;
function ScrollWindow(hWnd:THandle; XAmount, YAmount:longint;lpRect:PRECT; lpClipRect:PRECT):Boolean;
function SetBrushOrgEx(DC:HDC; nXOrg, nYOrg:longint; lppt:PPOINT):Boolean;
function SetTimer(hWnd:THandle; nIDEvent:UINT_PTR; uElapse:LongWord; lpTimerFunc:TTimerNotify):UINT_PTR;
function SubtractRect(var lprcDst: TRect; const lprcSrc1, lprcSrc2: TRect): Boolean;
function TextOutW(DC: HDC; X,Y : Integer; Str : PWideChar; Count: Integer) : Boolean;
function ToAscii(uVirtKey, uScanCode:LongWord; lpKeyState: PByte; lpChar: PWord; uFlags:LongWord): LongInt;
function UpdateWindow(Handle: HWND): Boolean;
implementation
uses
{$i uses.inc}
maps, LCLProc, LCLMessageGlue, Controls
{$ifdef DEBUG_DELPHICOMPAT}
,multiloglcl, filechannel
{$endif}
;
{$ifdef DEBUG_DELPHICOMPAT}
const
//Logger classes
lcInfo = 0;
lcStack = 1;
var
Logger: TLCLLogger;
{$endif}
{$i delphicompat.inc}
initialization
FTimerList := TTimerList.Create;
{$ifdef DEBUG_DELPHICOMPAT}
Logger := TLCLLogger.Create;
Logger.Channels.Add(TFileChannel.Create('delphicompat.log'));
Logger.ActivateClasses := [lcInfo,lcStack];
Logger.MaxStackCount := 3;
{$endif}
finalization
FTimerList.Free;
{$ifdef DEBUG_DELPHICOMPAT}
Logger.Free;
{$endif}
end.

82
components/lclextensions/include/carbon/delphicompat.inc Executable file
View File

@ -0,0 +1,82 @@
{
Carbon Interface
Dummy implementation. Not tested.
Waiting for someone with a Mac to implement it
}
type
TTimerList = class
end;
var
FTimerList: TTimerList;
function CF_UNICODETEXT: TClipboardFormat;
begin
//todo
Result := TClipboardFormat(0);
end;
{
Only a few functions are necessary to compile VirtualTreeView:
BitBlt
GetCurrentObject
Set/KillTimer (Look at Qt/Gtk implementation)
}
{$define HAS_GETCURRENTOBJECT}
{.$define HAS_MAPMODEFUNCTIONS}
{.$define HAS_GETTEXTEXTENTEXPOINT}
{.$define HAS_GETDOUBLECLICKTIME}
{.$define HAS_GETTEXTALIGN}
{.$define HAS_GETWINDOWDC}
{.$define HAS_INVERTRECT}
{.$define HAS_OFFSETRGN}
{.$define HAS_REDRAWWINDOW}
{.$define HAS_SCROLLWINDOW}
{.$define HAS_SETBRUSHORGEX}
{$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 := StretchMaskBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc,
Width, Height, 0, 0, 0, Rop);
end;
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
var
CarbonDC: TCarbonDeviceContext absolute hdc;
begin
Result := 0;
with CarbonDC do
begin
case uObjectType of
OBJ_BITMAP:
begin
if CarbonDC is TCarbonBitmapContext then
Result := HGDIOBJ(TCarbonBitmapContext(CarbonDC).Bitmap);
end;
OBJ_BRUSH: Result := HGDIOBJ(CurrentBrush);
OBJ_FONT: Result := HGDIOBJ(CurrentFont);
OBJ_PEN: Result := HGDIOBJ(CurrentPen);
end;
end;
end;
function KillTimer(hWnd: THandle; nIDEvent: UINT_PTR):Boolean;
begin
Result := LCLIntf.KillTimer(hWnd, nIDEvent);
end;
function SetTimer(hWnd: THandle; nIDEvent: UINT_PTR; uElapse: LongWord; lpTimerFunc: TTimerNotify): UINT_PTR;
begin
Result := LCLIntf.SetTimer(hWnd, nIDEvent, uElapse, nil{lpTimerFunc});
end;

24
components/lclextensions/include/carbon/lclext.inc Executable file
View File

@ -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 := StretchMaskBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
Mask, 0, 0, SRCCOPY);
end;
function OptimalPixelFormat: TPixelFormat;
begin
Result := pfDevice;
end;
function OSSupportsUTF16: Boolean;
begin
Result := False;
end;

1
components/lclextensions/include/carbon/uses.inc Executable file
View File

@ -0,0 +1 @@
InterfaceBase, LCLIntf, Graphics, CarbonInt, CarbonCanvas, Math,

2
components/lclextensions/include/carbon/uses_lclext.inc Executable file
View File

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

67
components/lclextensions/include/cocoa/delphicompat.inc Executable file
View File

@ -0,0 +1,67 @@
{
Carbon Interface
Dummy implementation. Not tested.
Waiting for someone with a Mac to implement it
}
type
TTimerList = class
end;
var
FTimerList: TTimerList;
function CF_UNICODETEXT: TClipboardFormat;
begin
//todo
Result := TClipboardFormat(0);
end;
{
Only a few functions are necessary to compile VirtualTreeView:
BitBlt
GetCurrentObject
Set/KillTimer (Look at Qt/Gtk implementation)
}
{$define HAS_GETCURRENTOBJECT}
{.$define HAS_MAPMODEFUNCTIONS}
{.$define HAS_GETTEXTEXTENTEXPOINT}
{.$define HAS_GETDOUBLECLICKTIME}
{.$define HAS_GETTEXTALIGN}
{.$define HAS_GETWINDOWDC}
{.$define HAS_INVERTRECT}
{.$define HAS_OFFSETRGN}
{.$define HAS_REDRAWWINDOW}
{.$define HAS_SCROLLWINDOW}
{.$define HAS_SETBRUSHORGEX}
{$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 := StretchMaskBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc,
Width, Height, 0, 0, 0, Rop);
end;
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
begin
Result := LCLIntf.GetCurrentObject(hdc, uObjectType);
end;
function KillTimer(hWnd: THandle; nIDEvent: UINT_PTR):Boolean;
begin
Result := LCLIntf.KillTimer(hWnd, nIDEvent);
end;
function SetTimer(hWnd: THandle; nIDEvent: UINT_PTR; uElapse: LongWord; lpTimerFunc: TTimerNotify): UINT_PTR;
begin
Result := LCLIntf.SetTimer(hWnd, nIDEvent, uElapse, nil{lpTimerFunc});
end;

24
components/lclextensions/include/cocoa/lclext.inc Executable file
View File

@ -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 := StretchMaskBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
Mask, 0, 0, SRCCOPY);
end;
function OptimalPixelFormat: TPixelFormat;
begin
Result := pfDevice;
end;
function OSSupportsUTF16: Boolean;
begin
Result := False;
end;

1
components/lclextensions/include/cocoa/uses.inc Executable file
View File

@ -0,0 +1 @@
InterfaceBase, LCLIntf, Graphics, CocoaInt, Math,

2
components/lclextensions/include/cocoa/uses_lclext.inc Executable file
View File

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

38
components/lclextensions/include/generic/independentfunctions.inc Executable file
View File

@ -0,0 +1,38 @@
function MapWindowPoints(hWndFrom, hWndTo: HWND; var lpPoints; cPoints: UINT): Integer;
var
i: Integer;
XOffset, YOffset: SmallInt;
FromPoint, ToPoint: TPoint;
begin
FromPoint := Point(0, 0);
ToPoint := Point(0, 0);
if hWndFrom <> 0 then
ClientToScreen(hWndFrom, FromPoint);
if hWndTo <> 0 then
ClientToScreen(hWndTo, ToPoint);
XOffset := (FromPoint.X - ToPoint.X);
YOffset := (FromPoint.Y - ToPoint.Y);
for i := 0 to cPoints - 1 do
begin
PPoint(@lpPoints)[i].x := XOffset + PPoint(@lpPoints)[i].x;
PPoint(@lpPoints)[i].y := YOffset + PPoint(@lpPoints)[i].y;
end;
Result := MakeLong(XOffset, YOffset);
end;
{$ifndef HAS_GETDOUBLECLICKTIME}
function GetDoubleClickTime: UINT;
begin
//todo: see if gtk has a value. Use Windows default for now
Result := 500;
end;
{$endif}
{$ifndef HAS_REDRAWWINDOW}
function RedrawWindow(hWnd:THandle; lprcUpdate:PRECT; hrgnUpdate:HRGN; flags:LongWord):BOOLEAN;
begin
//todo: see if there's a better way of doing this
Result := LCLIntf.InvalidateRect(hWnd, lprcUpdate, (RDW_ERASE and flags) > 0);
end;
{$endif}

177
components/lclextensions/include/generic/stubs.inc Executable file
View File

@ -0,0 +1,177 @@
function BeginDeferWindowPos(nNumWindows:longint):THandle;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function CopyImage(hImage:THANDLE; uType:LongWord; cxDesired, cyDesired: LongInt; fuFlags:LongWord):THandle;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function DeferWindowPos(hWinPosInfo, hWnd, hWndInsertAfter:THandle; x, y, cx, cy:longint; uFlags:LongWord):THandle;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function EndDeferWindowPos(hWinPosInfo:THandle):Boolean;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GdiFlush: Boolean;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GetACP:LongWord;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$ifndef HAS_GETBKCOLOR}
function GetBkColor(DC:HDC):COLORREF;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
{$ifndef HAS_GETCURRENTOBJECT}
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
function GetDCEx(hWnd:THandle; hrgnClip:HRGN; flags:DWORD):HDC;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GetKeyboardLayout(dwLayout:DWORD):THandle;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GetKeyboardState(lpKeyState: System.PByte):BOOLEAN;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GetLocaleInfo(Locale, LCType:LongWord; lpLCData:PChar; cchData:longint):longint;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$ifndef HAS_GETTEXTEXTENTEXPOINT}
function GetTextExtentExPoint(DC: HDC; Str: PChar;
Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger;
var Size: TSize): BOOL;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
{$ifndef HAS_GETTEXTALIGN}
function GetTextAlign(hDC:HDC): LongWord;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
{$ifndef HAS_GETWINDOWDC}
function GetWindowDC(hWnd:THandle):HDC;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
function ImageList_DragShowNolock(fShow: Boolean): Boolean;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$ifndef HAS_INVERTRECT}
function InvertRect(DC: HDC; const lprc: TRect): Boolean;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
function MultiByteToWideChar(CodePage, dwFlags:DWORD; lpMultiByteStr:PChar; cchMultiByte:longint; lpWideCharStr:PWideChar;cchWideChar:longint):longint;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$ifndef HAS_OFFSETRGN}
function OffsetRgn(hrgn:HRGN; nxOffset, nYOffset:longint):longint;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
function ScrollDC(DC:HDC; dx:longint; dy:longint; var lprcScroll:TRECT; var lprcClip:TRECT;hrgnUpdate:HRGN; lprcUpdate:PRECT):Boolean;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$ifndef HAS_SCROLLWINDOW}
function ScrollWindow(hWnd:THandle; XAmount, YAmount:longint;lpRect:PRECT; lpClipRect:PRECT):Boolean;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
{$ifndef HAS_SETBRUSHORGEX}
function SetBrushOrgEx(DC:HDC; nXOrg, nYOrg:longint; lppt:PPOINT):Boolean;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
{$endif}
function SubtractRect(var lprcDst: TRect; const lprcSrc1, lprcSrc2: TRect): BOOLEAN;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function ToAscii(uVirtKey, uScanCode:LongWord; lpKeyState: System.PByte; lpChar: System.PWord; uFlags:LongWord):longint;
begin
Result := 0;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;
function UpdateWindow(Handle: HWND): Boolean;
begin
Result := False;
{$ifdef DEBUG_DELPHICOMPAT} Logger.SendCallStack('Dummy WinAPI Implementation'); {$endif}
end;

8
components/lclextensions/include/generic/timerfunctions.inc Executable file
View File

@ -0,0 +1,8 @@
function KillTimer(hWnd:THandle; nIDEvent: LongWord):Boolean;
begin
end;
function SetTimer(hWnd:THandle; nIDEvent:LongWord; uElapse:LongWord; lpTimerFunc:TTimerNotify): LongWord;
begin
end;

84
components/lclextensions/include/generic/unicodefunctions.inc Executable file
View File

@ -0,0 +1,84 @@
{
GetUTF8ByteCount returns the number of bytes necessary to hold the requested number
of characters (count). Not necessarily the number of characters is equal to the
widestring length but here we assume it to skip the extra overhead
}
//todo do a function that convert the str and the count at one pass
function GetUTF8ByteCount(const UTF8Str: UTF8String; WideCount: Integer): Integer;
var
CharCount, CharLen, StrLen: Integer;
P: PChar;
begin
Result := 0;
CharCount := 0;
P := PChar(UTF8Str);
StrLen := Length(UTF8Str);
WideCount := Min(WideCount, StrLen);
while (CharCount < WideCount) do
begin
CharLen := UTF8CharacterLength(P);
Inc(P, CharLen);
Inc(Result, CharLen);
Inc(CharCount);
end;
Result := Min(Result, StrLen);
end;
{$ifndef HAS_DRAWTEXTW}
function DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; var lpRect: TRect; uFormat: LongWord): Integer;
var
TempStr: UTF8String;
begin
TempStr := UTF8Encode(WideString(lpString));
Result := DrawText(hDC, PChar(TempStr), GetUTF8ByteCount(TempStr, nCount),
lpRect, uFormat);
end;
{$endif}
function ExtTextOutW(DC: HDC; X, Y: Integer; Options: LongInt; Rect: PRect;
Str: PWideChar; Count: LongInt; Dx: ObjPas.PInteger): Boolean;
var
TempStr: UTF8String;
begin
TempStr := UTF8Encode(WideString(Str));
Result := ExtTextOut(DC, X, Y, Options, Rect, PChar(TempStr),
GetUTF8ByteCount(TempStr, Count), Dx);
end;
function GetTextExtentPoint32W(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
var
TempStr: UTF8String;
begin
TempStr := UTF8Encode(WideString(Str));
Result := GetTextExtentPoint(DC, PChar(TempStr),
GetUTF8ByteCount(TempStr, Count), Size);
end;
function GetTextExtentExPointW(DC: HDC; Str: PWideChar;
Count, MaxWidth: Integer; MaxCount, PartialWidths: ObjPas.PInteger;
var Size: TSize): BOOL;
var
TempStr: UTF8String;
begin
TempStr := UTF8Encode(WideString(Str));
Result := DelphiCompat.GetTextExtentExPoint(DC, PChar(TempStr),
Count, MaxWidth, MaxCount, PartialWidths, Size);
end;
function GetTextExtentPointW(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
var
TempStr: UTF8String;
begin
TempStr := UTF8Encode(WideString(Str));
Result := GetTextExtentPoint(DC, PChar(TempStr),
GetUTF8ByteCount(TempStr, Count), Size);
end;
function TextOutW(DC: HDC; X,Y : Integer; Str : PWideChar; Count: Integer) : Boolean;
var
TempStr: UTF8String;
begin
TempStr := UTF8Encode(WideString(Str));
Result := TextOut(DC, X, Y, PChar(TempStr), GetUTF8ByteCount(TempStr, Count));
end;

336
components/lclextensions/include/gtk/delphicompat.inc Executable file
View File

@ -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;

24
components/lclextensions/include/gtk/lclext.inc Executable file
View File

@ -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;

3
components/lclextensions/include/gtk/uses.inc Executable file
View File

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

2
components/lclextensions/include/gtk/uses_lclext.inc Executable file
View File

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

394
components/lclextensions/include/gtk2/delphicompat.inc Executable file
View File

@ -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;

22
components/lclextensions/include/gtk2/lclext.inc Executable file
View File

@ -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;

2
components/lclextensions/include/gtk2/uses.inc Executable file
View File

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

2
components/lclextensions/include/gtk2/uses_lclext.inc Executable file
View File

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

404
components/lclextensions/include/qt/delphicompat.inc Executable file
View File

@ -0,0 +1,404 @@
{
Qt Interface
Initial implementation by Zeljan Rikalo
SetTimer/KillTimer implementation by Luiz Americo
}
function CF_UNICODETEXT: TClipboardFormat;
begin
//todo
Result := TClipboardFormat(0);
end;
{$define HAS_GETBKCOLOR}
{$define HAS_GETCURRENTOBJECT}
{$define HAS_INVERTRECT}
{$define HAS_GETTEXTEXTENTEXPOINT}
{$define HAS_GETDOUBLECLICKTIME}
{$define HAS_GETTEXTALIGN}
{$define HAS_GETWINDOWDC}
{$define HAS_OFFSETRGN}
{$define HAS_REDRAWWINDOW}
{$define HAS_SCROLLWINDOW}
{$define HAS_SETBRUSHORGEX}
{$i ../generic/stubs.inc}
{$i ../generic/independentfunctions.inc}
{$i ../generic/unicodefunctions.inc}
function GetBkColor(DC:HDC):COLORREF;
var
Color: PQColor;
begin
if QtWidgetSet.IsValidDC(DC) then
begin
Color := TQtDeviceContext(DC).BackgroundBrush.getColor;
TQColorToColorRef(Color^, Result);
end else
Result := CLR_INVALID;
end;
function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
YSrc: Integer; Rop: DWORD): Boolean;
begin
Result := StretchBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width,
Height, ROP);
end;
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
begin
Result := 0;
if QtWidgetSet.IsValidDC(hdc) then
with TQtDeviceContext(hdc) do
begin {TODO: FIXME}
case uObjectType of
OBJ_BITMAP: Result := HGDIOBJ(vImage);
OBJ_BRUSH: Result := HGDIOBJ(vBrush);
OBJ_FONT: Result := HGDIOBJ(vFont);
OBJ_PEN: Result := HGDIOBJ(vPen);
end;
end;
end;
function GetDoubleClickTime: UINT;
begin
Result := QApplication_doubleClickInterval;
end;
function GetTextExtentExPoint(DC: HDC; Str: PChar;
Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger;
var Size: TSize): BOOL;
begin
Result := QtWidgetSet.GetTextExtentExPoint(DC, Str, Count, MaxWidth, MaxCount, PartialWidths, Size);
end;
function GetTextAlign(hDC:HDC): LongWord;
var
QtDC: TQtDeviceContext;
QtFontMetrics: QFontMetricsH;
QtFont: QFontH;
begin
Result := 0;
if not QtWidgetSet.IsValidDC(hdC) then
Exit;
QtDC := TQtDeviceContext(hDC);
QtFont := QtDC.vFont.FHandle;
QtFontMetrics := QFontMetrics_create(QtFont);
try
{TODO: FIXME we should save somehow text flags into QtDC
cause we don't have any function which returns current flags !}
finally
QFontMetrics_destroy(QtFontMetrics);
end;
end;
function GetWindowDC(hWnd:THandle): HDC;
begin
Result := LCLIntf.GetDC(hWnd);
end;
function InvertRect(DC: HDC; const lprc: TRect): Boolean;
var
DCOrigin: TQtPoint;
begin
//todo: see the windows result when rect is invalid
Result := QtWidgetSet.IsValidDC(DC) and (lprc.Bottom > lprc.Top)
and (lprc.Right > lprc.Left);
if Result then
begin
with lprc do
Result := BitBlt(DC, Left, Top, Right - Left, Bottom-Top,
DC, Left, Top, LongWord(QPainterCompositionMode_DestinationOver));
{TODO: FIXME !}
end;
end;
function OffsetRgn(hrgn:HRGN; nxOffset, nYOffset:longint):longint;
var
Region: TQtRegion;
begin
Region := TQtRegion(hrgn);
QRegion_translate(Region.FHandle, nxOffset, nYOffset);
Result := Region.GetRegionType;
end;
function RedrawWindow(hWnd:THandle; lprcUpdate:PRECT; hrgnUpdate:HRGN; flags:LongWord):BOOLEAN;
begin
Result := QtWidgetSet.RedrawWindow(hWnd, lprcUpdate, hrgnUpdate, flags);
end;
function ScrollWindow(hWnd:THandle; XAmount, YAmount:longint;lpRect:PRECT; lpClipRect:PRECT): Boolean;
begin
Result := False;
if hWnd = 0 then
Exit;
QWidget_scroll(TQtWidget(hWnd).Widget, XAmount, YAmount, lpRect);
Result := True;
end;
function SetBrushOrgEx(DC:HDC; nXOrg, nYOrg:longint; lppt:PPOINT):Boolean;
var
QtDC: TQtDeviceContext;
begin
Result := False;
if not QtWidgetSet.IsValidDC(DC) then
Exit;
QtDC := TQtDeviceContext(DC);
if lppt <> nil then
QtDC.getBrushOrigin(lppt);
QtDC.setBrushOrigin(nXorg, nYOrg);
Result := True;
end;
type
TTimerID = record
hWnd: THandle;
nIDEvent: UINT_PTR;
end;
{ TQtTimerEx }
TQtTimerEx = class(TQtObject)
private
FTimerHook: QTimer_hookH;
FWidgetHook: QObject_hookH;
FCallbackFunc: TTimerNotify;
FID: UINT_PTR;
FHandle: THandle;
FControl: TWinControl;
public
constructor Create(hWnd: THandle; nIDEvent: UINT_PTR; TimerFunc: TTimerNotify);
destructor Destroy; override;
procedure AttachEvents; override;
procedure DetachEvents; override;
procedure signalWidgetDestroyed; cdecl;
procedure signalTimeout; cdecl;
public
function EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl; override;
procedure Start(Interval: Integer);
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): TQtTimerEx;
function Get(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify): TQtTimerEx;
end;
TQtWidgetSetHack = Class(TWidgetSet)
private
App: QApplicationH;
end;
var
FTimerList: TTimerList;
{ TQtTimerEx }
constructor TQtTimerEx.Create(hWnd: THandle; nIDEvent: UINT_PTR; TimerFunc: TTimerNotify);
var
AName: WideString;
begin
inherited Create;
FDeleteLater := True;
FCallbackFunc := TimerFunc;
FID := nIDEvent;
FControl := FindControl(hWnd);
FHandle := hWnd;
if hWnd <> 0 then
begin
FWidgetHook := QObject_hook_create(TQtWidget(hWnd).TheObject);
QObject_hook_hook_destroyed(FWidgetHook, @signalWidgetDestroyed);
end;
//very big ultra extreme hack to get the app from QtWidgetset
TheObject := QTimer_create(TQtWidgetSetHack(QtWidgetSet).App);
AName := 'tqttimerex';
QObject_setObjectName(TheObject, @AName);
AttachEvents;
end;
destructor TQtTimerEx.Destroy;
begin
if FWidgetHook <> nil then
QObject_hook_destroy(FWidgetHook);
inherited Destroy;
end;
procedure TQtTimerEx.AttachEvents;
begin
FTimerHook := QTimer_hook_create(QTimerH(TheObject));
QTimer_hook_hook_timeout(FTimerHook, @signalTimeout);
inherited AttachEvents;
end;
procedure TQtTimerEx.DetachEvents;
begin
QTimer_stop(QTimerH(TheObject));
if FTimerHook <> nil then
QTimer_hook_destroy(FTimerHook);
inherited DetachEvents;
end;
procedure TQtTimerEx.signalWidgetDestroyed; cdecl;
begin
Stop;
FTimerList.Delete(FHandle, FID);
Destroy;
end;
procedure TQtTimerEx.signalTimeout; cdecl;
begin
if Assigned(FCallbackFunc) then
FCallbackFunc(FID)
else if Assigned(FControl) then
begin
if ([csLoading, csDestroying] * FControl.ComponentState = []) and not
(csDestroyingHandle in FControl.ControlState) then
begin
LCLSendTimerMsg(FControl, FID, 0);
end;
end
else
begin
//orphan timer. Stop.
//todo: better to remove from the list?
Stop;
end;
end;
function TQtTimerEx.EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl;
begin
Result := False;
QEvent_accept(Event);
end;
procedure TQtTimerEx.Start(Interval: Integer);
begin
QTimer_start(QTimerH(TheObject), Interval);
end;
procedure TQtTimerEx.Stop;
begin
QTimer_stop(QTimerH(TheObject));
end;
function KillTimer(hWnd: THandle; nIDEvent: UINT_PTR): Boolean;
var
TimerObject: TQtTimerEx;
begin
Result := True;
TimerObject := FTimerList.Find(hWnd, nIDEvent);
if TimerObject <> nil then
begin
// DebugLn('KillTimer HWnd: %d ID: %d TimerObject: %d',[hWnd, nIDEvent, PtrInt(TimerObject)]);
TimerObject.Stop;
end;
end;
function SetTimer(hWnd: THandle; nIDEvent: UINT_PTR; uElapse: LongWord; lpTimerFunc: TTimerNotify): UINT_PTR;
var
TimerObject: TQtTimerEx;
begin
TimerObject := FTimerList.Get(hWnd, nIDEvent, lpTimerFunc);
try
TimerObject.Start(uElapse);
if hWnd = 0 then
Result := PtrInt(TimerObject)
else
Result := nIdEvent;
except
Result := 0;
end;
//DebugLn('SetTimer HWnd: %d ID: %d TimerObject: %d',[hWnd, nIDEvent, PtrInt(TimerObject)]);
end;
function TTimerList.Get(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify): TQtTimerEx;
var
AID: TTimerID;
begin
AID.hWnd := hWnd;
AID.nIDEvent := nIDEvent;
with FMap do
begin
if HasId(AID) then
begin
// DebugLn('Reset timer for HWnd: %d ID: %d AID: %d', [hWnd, ID, AID]);
GetData(AID, Result);
Result.FCallbackFunc := NotifyFunc;
end
else
begin
// DebugLn('Create timer for HWnd: %d ID: %d AID: %d', [hWnd, ID, AID]);
Result := TQtTimerEx.Create(hWnd, nIDEvent, NotifyFunc);
if hWnd = 0 then
begin
AID.nIDEvent := PtrUInt(Result);
Result.FID := PtrUInt(Result);
end;
Add(AID, Result);
end;
end;
end;
constructor TTimerList.Create;
begin
FMap := TMap.Create({$ifdef CPU64}itu16{$else}itu8{$endif}, SizeOf(TQtTimerEx));
end;
destructor TTimerList.Destroy;
var
Iterator: TMapIterator;
TimerObject: TQtTimerEx;
begin
Iterator := TMapIterator.Create(FMap);
with Iterator do
begin
while not EOM do
begin
GetData(TimerObject);
TimerObject.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.Find(hWnd: THandle; nIDEvent: UINT_PTR): TQtTimerEx;
var
DataPtr: ^TQtTimerEx;
TimerID: TTimerID;
begin
Result := nil;
TimerID.hWnd := hWnd;
TimerID.nIDEvent := nIDEvent;
// DebugLn('GetTimerObject for HWnd: %d ID: %d AID: %d', [hWnd, nIDEvent, TimerID]);
DataPtr := FMap.GetDataPtr(TimerID);
if DataPtr <> nil then
Result := DataPtr^;
end;

24
components/lclextensions/include/qt/lclext.inc Executable file
View File

@ -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 := StretchMaskBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height,
Mask, 0, 0, SRCCOPY);
end;
function OptimalPixelFormat: TPixelFormat;
begin
Result := pfDevice;
end;
function OSSupportsUTF16: Boolean;
begin
Result := False;
end;

1
components/lclextensions/include/qt/uses.inc Executable file
View File

@ -0,0 +1 @@
InterfaceBase, LCLIntf, Graphics, qt4, qtint, qtobjects, qtwidgets, Math,

2
components/lclextensions/include/qt/uses_lclext.inc Executable file
View File

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

398
components/lclextensions/include/win32/delphicompat.inc Executable file
View File

@ -0,0 +1,398 @@
{ 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.
}
function BeginDeferWindowPos(nNumWindows: longint): THandle;
begin
Result:=Windows.BeginDeferWindowPos(nNumWindows);
end;
function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
YSrc: Integer; Rop: DWORD): Boolean;
begin
Result := Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Rop);
end;
function CF_UNICODETEXT: TClipboardFormat;
begin
Result:=Windows.CF_UNICODETEXT;
end;
function CopyImage(hImage: THANDLE; uType: LongWord; cxDesired,
cyDesired: LongInt; fuFlags: LongWord): THandle;
begin
Result := Windows.CopyImage(hImage,uType,cxDesired,cyDesired,fuFlags);
end;
function CreatePatternBrush(hbmp: HBITMAP): HBRUSH;
begin
Result := Windows.CreatePatternBrush(hbmp);
end;
function DeferWindowPos(hWinPosInfo, hWnd, hWndInsertAfter: THandle;
x, y, cx, cy: longint; uFlags: LongWord): THandle;
begin
Result := Windows.DeferWindowPos(hWinPosInfo,hWnd,hWndInsertAfter,x,y,cx,cy,uFlags);
end;
function DrawFrameControl(DC: HDC; const Rect: TRect; uType, uState: LongWord): Boolean;
begin
Result := Windows.DrawFrameControl(DC,Rect,uType,uState);
end;
function DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer;
var lpRect: TRect; uFormat: LongWord): Integer;
begin
Result := Windows.DrawTextW(hDC,lpString,nCount,lpRect,uFormat);
end;
function EndDeferWindowPos(hWinPosInfo: THandle): Boolean;
begin
Result:=Windows.EndDeferWindowPos(hWinPosInfo);
end;
function ExtTextOutW(DC: LCLType.HDC; X, Y: Integer; Options: LongInt; Rect: Types.PRect;
Str: PWideChar; Count: LongInt; Dx: ObjPas.PInteger): Boolean;
begin
Result := Windows.ExtTextOutW(DC, X, Y, Options, Rect,Str, Count, Dx);
end;
function GdiFlush: Boolean;
begin
Result := Windows.GdiFlush;
end;
function GetACP: LongWord;
begin
Result := Windows.GetACP;
end;
function GetBkColor(DC: HDC): LCLType.COLORREF;
begin
Result := Windows.GetBkColor(DC);
end;
function GetCurrentObject(hdc: HDC; uObjectType: UINT): HGDIOBJ;
begin
Result := Windows.GetCurrentObject(hdc, uObjectType);
end;
function GetDCEx(hWnd: THandle; hrgnClip: HRGN; flags: DWORD): HDC;
begin
Result := Windows.GetDCEx(hWnd,hrgnClip,flags);
end;
function GetDoubleClickTime: UINT;
begin
Result := Windows.GetDoubleClickTime;
end;
function GetKeyboardLayout(dwLayout: DWORD): THandle;
begin
Result := Windows.GetKeyboardLayout(dwLayout);
end;
function GetKeyboardState(lpKeyState: PBYTE): BOOLEAN;
begin
Result := Windows.GetKeyboardState(lpKeyState);
end;
function GetLocaleInfo(Locale, LCType: LongWord; lpLCData: PChar;
cchData: longint): longint;
begin
Result := Windows.GetLocaleInfo(Locale,LCType,lpLCData,cchData);
end;
{$if lcl_release < 29}
function GetMapMode(DC: HDC): LongInt;
begin
Result := Windows.GetMapMode(DC);
end;
{$endif}
function GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall; external 'GDI32.DLL';
function GetTextAlign(hDC: HDC): LongWord;
begin
Result := Windows.GetTextAlign(hDC);
end;
function GetTextExtentExPoint(DC: LCLType.HDC; Str: PChar;
Count, MaxWidth: Integer; MaxCount, PartialWidths: ObjPas.PInteger;
var Size: TSize): BOOL;
begin
Result := Windows.GetTextExtentExPoint(DC, Str, Count, MaxWidth, MaxCount, PartialWidths, Size);
end;
function GetTextExtentExPointW(DC: LCLType.HDC; Str: PWideChar;
Count, MaxWidth: Integer; MaxCount, PartialWidths: ObjPas.PInteger;
var Size: Types.TSize): BOOL;
begin
Result := Windows.GetTextExtentExPointW(DC, Str, Count, MaxWidth, MaxCount, PartialWidths, Size);
end;
function GetTextExtentPoint32W(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
begin
Result := Windows.GetTextExtentPointW(DC, Str, Count, Size);
end;
function GetTextExtentPointW(DC: HDC; Str: PWideChar; Count: Integer; out Size: TSize): Boolean;
begin
Result := Windows.GetTextExtentPointW(DC, Str, Count, Size);
end;
function GetWindowDC(hWnd: THandle): HDC;
begin
Result := Windows.GetWindowDC(hWnd);
end;
function ImageList_DragShowNolock(fShow: Boolean): Boolean;
begin
Result := CommCtrl.ImageList_DragShowNolock(fShow);
end;
function InvertRect(DC: HDC; const lprc: TRect): Boolean;
begin
Result := Windows.InvertRect(DC, PRect(@lprc)^);
end;
function LPtoDP(DC: HDC; var Points; Count: Integer): BOOLEAN;
begin
Result := Windows.LPToDP(DC,Points,Count);
end;
function MapWindowPoints(hWndFrom, hWndTo: HWND; var lpPoints; cPoints: UINT
): Integer;
begin
Result:=Windows.MapWindowPoints(hWndFrom,hWndTo,lpPoints,cPoints);
end;
function MultiByteToWideChar(CodePage, dwFlags: DWORD; lpMultiByteStr: PChar;
cchMultiByte: longint; lpWideCharStr: PWideChar; cchWideChar: longint
): longint;
begin
Result := Windows.MultiByteToWideChar(CodePage,dwFlags,lpMultiByteStr,cchMultiByte,lpWideCharStr,cchWideChar);
end;
function OffsetRgn(hrgn: HRGN; nxOffset, nYOffset: longint): longint;
begin
Result := Windows.OffsetRgn(hrgn,nxOffset,nYOffset);
end;
function RedrawWindow(hWnd: THandle; lprcUpdate: Types.PRECT; hrgnUpdate: HRGN;
flags: LongWord): BOOLEAN;
begin
Result := Windows.RedrawWindow(hWnd,lprcUpdate,hrgnUpdate,flags);
end;
function SetBrushOrgEx(DC: LCLType.HDC; nXOrg, nYOrg: longint; lppt: Types.PPoint): Boolean;
begin
Result := Windows.SetBrushOrgEx(DC,nXOrg,nYOrg,lppt);
end;
{$if lcl_release < 29}
function SetMapMode(DC: HDC; fnMapMode: LongInt): LongInt;
begin
Result := Windows.SetMapMode(DC, fnMapMode);
end;
{$endif}
function ScrollDC(DC: LCLType.HDC; dx: longint; dy: longint; var lprcScroll: Types.TRect;
var lprcClip: Types.TRect; hrgnUpdate: LCLType.HRGN; lprcUpdate: Types.PRect): Boolean;
begin
Result := Windows.ScrollDC(DC, dx, dy, lprcScroll, lprcClip, hrgnUpdate, lprcUpdate);
end;
function ScrollWindow(hWnd: THandle; XAmount, YAmount: longint; lpRect: Types.PRect;
lpClipRect: Types.PRect): Boolean;
begin
Result := Windows.ScrollWindow(hWnd,XAmount,YAmount,lpRect,lpClipRect);
end;
function SubtractRect(var lprcDst: TRect; const lprcSrc1, lprcSrc2: TRect
): BOOLEAN;
begin
Result := Windows.SubtractRect(lprcDst,lprcSrc1,lprcSrc2);
end;
function TextOutW(DC: HDC; X,Y : Integer; Str : PWideChar; Count: Integer) : Boolean;
begin
Result := Windows.TextOutW(DC,X,Y,Str,Count);
end;
function ToAscii(uVirtKey, uScanCode: LongWord; lpKeyState: PBYTE;
lpChar: PWORD; uFlags: LongWord): longint;
begin
Result := Windows.ToAscii(uVirtKey,uScanCode,lpKeyState,lpChar,uFlags);
end;
function UpdateWindow(Handle: HWND): Boolean;
begin
Result := Windows.UpdateWindow(Handle);
end;
type
TTimerID = record
hWnd: THandle;
nIDEvent: UINT_PTR;
end;
TTimerRecord = record
Control: TControl;
Notify: TTimerNotify;
end;
PTimerRecord = ^TTimerRecord;
{ TTimerList }
TTimerList = class
private
FMap: TMap;
public
constructor Create;
destructor Destroy; override;
procedure Add(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify; Control: TControl);
function GetTimerInfo(hWnd: THandle; nIDEvent: UINT_PTR; out TimerInfo: TTimerRecord):Boolean;
function GetTimerInfoPtr(hWnd: THandle; nIDEvent: UINT_PTR): PTimerRecord;
end;
var
FTimerList: TTimerList;
{ TTimerList }
constructor TTimerList.Create;
begin
FMap := TMap.Create({$ifdef CPU64}itu16{$else}itu8{$endif}, SizeOf(TTimerRecord));
end;
destructor TTimerList.Destroy;
begin
FMap.Destroy;
inherited Destroy;
end;
procedure TTimerList.Add(hWnd: THandle; nIDEvent: UINT_PTR; NotifyFunc: TTimerNotify; Control: TControl);
var
TimerID: TTimerID;
TimerRec: TTimerRecord;
begin
TimerRec.Notify := NotifyFunc;
TimerRec.Control := Control;
TimerID.hWnd := hWnd;
TimerID.nIDEvent := nIDEvent;
with FMap do
begin
if HasId(TimerID) then
SetData(TimerID, TimerRec)
else
Add(TimerID, TimerRec);
end;
end;
function TTimerList.GetTimerInfo(hWnd: THandle; nIDEvent: UINT_PTR;
out TimerInfo: TTimerRecord): Boolean;
var
TimerID: TTimerID;
begin
TimerID.hWnd := hWnd;
TimerID.nIDEvent := nIDEvent;
Result := FMap.GetData(TimerID, TimerInfo);
end;
function TTimerList.GetTimerInfoPtr(hWnd: THandle; nIDEvent: UINT_PTR): PTimerRecord;
var
TimerID: TTimerID;
begin
TimerID.hWnd := hWnd;
TimerID.nIDEvent := nIDEvent;
Result := FMap.GetDataPtr(TimerID);
end;
//workaround to buggy fpc header
type
TIMERPROC64 = procedure (hWnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
function SetTimer64(hWnd: HWND; nIDEvent: UINT_PTR; uElapse: UINT; lpTimerFunc: TIMERPROC64): UINT_PTR; stdcall external 'user32' name 'SetTimer';
function KillTimer64(hWnd: HWND; uIDEvent: UINT_PTR):WINBOOL; stdcall external 'user32' name 'KillTimer';
procedure TimerCallBack(Handle: hWnd; Msg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall;
var
TimerInfo: PTimerRecord;
begin
//DebugLn('Executing Timer to Handle %d - ID: %d',[Handle, idEvent]);
TimerInfo := FTimerList.GetTimerInfoPtr(Handle, idEvent);
if TimerInfo <> nil then
with TimerInfo^ do
begin
if Notify <> nil then
Notify(idEvent)
else
begin
if Control <> nil then
LCLSendTimerMsg(Control,idEvent,0);
end;
end
else
DebugLn('Warning - No TimerInfo found for Hwnd: %d Id: %d',[Handle,idEvent]);
end;
function SetTimer(hWnd: THandle; nIDEvent: UINT_PTR; uElapse:LongWord; lpTimerFunc: TTimerNotify):UINT_PTR;
var
WinInfo: PWin32WindowInfo;
begin
if hWnd <> 0 then
begin
WinInfo := GetWin32WindowInfo(hWnd);
FTimerList.Add(hWnd,nIDEvent,lpTimerFunc,WinInfo^.WinControl);
Result := SetTimer64(hWnd,nIDEvent,uElapse,@TimerCallBack);
end
else
begin
//if handle is 0, the callback is mandatory otherwise we get a zombie timer
if lpTimerFunc <> nil then
begin
Result := SetTimer64(hWnd,nIDEvent,uElapse,@TimerCallBack);
FTimerList.Add(hWnd,Result,lpTimerFunc,nil);
end
else
Result := 0;
end;
//DebugLn('SetTimer - Handle %d - ID: %d - Result: %d',[hWnd,nIDEvent,Result]);
end;
function KillTimer(hWnd: THandle; nIDEvent: UINT_PTR):Boolean;
begin
Result := KillTimer64(hWnd,nIDEvent);
//DebugLn('KillTimer - Handle %d - ID: %d',[hWnd,nIDEvent]);
end;

61
components/lclextensions/include/win32/lclext.inc Executable file
View File

@ -0,0 +1,61 @@
function CreateBitmapMask(BitmapDC: HDC; Width, Height: Integer; TransparentColor: TColor): HBITMAP;
var
OldColor: COLORREF;
OldObj: HBITMAP;
MaskDC: HDC;
begin
Result := Windows.CreateBitmap(Width,Height,1,1,nil);
MaskDC := Windows.CreateCompatibleDC(BitmapDC);
OldObj := Windows.SelectObject(MaskDC,Result);
OldColor := Windows.SetBkColor(BitmapDC, Windows.COLORREF(ColorToRGB(TransparentColor)));
Windows.BitBlt(MaskDC,0,0,Width,Height,BitmapDC,0,0,SRCCOPY);
Windows.SetBkColor(BitmapDC,OldColor);
Windows.SelectObject(MaskDC,OldObj);
Windows.DeleteDC(MaskDC);
end;
function DirectMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP): Boolean;
var
MaskDC: HDC;
MaskObj: HGDIOBJ;
PrevTextColor, PrevBkColor: COLORREF;
begin
//this is a stripped version of LCL.StretchMaskBlt
if Mask <> 0 then
begin
MaskDC := Windows.CreateCompatibleDC(DestDC);
MaskObj := Windows.SelectObject(MaskDC, Mask);
PrevTextColor := Windows.SetTextColor(DestDC, $00000000);
PrevBkColor := Windows.SetBkColor(DestDC, $00FFFFFF);
Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, SRCINVERT);
Windows.BitBlt(DestDC, X, Y, Width, Height, MaskDC, XSrc, YSrc, SRCAND);
Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, SRCINVERT);
Windows.SetTextColor(DestDC, PrevTextColor);
Windows.SetBkColor(DestDC, PrevBkColor);
Windows.SelectObject(MaskDC, MaskObj);
Windows.DeleteDC(MaskDC);
end
else
Result := Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, SRCCOPY);
end;
function OptimalPixelFormat: TPixelFormat;
begin
if ScreenInfo.ColorDepth = 32 then
Result := pf32bit
else
Result := pfDevice;
end;
function OSSupportsUTF16: Boolean;
begin
Result := Win32Platform = VER_PLATFORM_WIN32_NT;
end;

3
components/lclextensions/include/win32/uses.inc Executable file
View File

@ -0,0 +1,3 @@
Windows, win32proc, CommCtrl,

2
components/lclextensions/include/win32/uses_lclext.inc Executable file
View File

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

58
components/lclextensions/lclext.pas Executable file
View File

@ -0,0 +1,58 @@
unit LclExt;
{ LCL Extension 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.
}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LCLType, Graphics;
function CreateBitmapMask(BitmapDC: HDC; Width, Height: Integer; TransparentColor: TColor): HBITMAP;
function DirectMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP): Boolean;
function OptimalPixelFormat: TPixelFormat;
function OSSupportsUTF16: Boolean;
implementation
{$i uses_lclext.inc}
{$i lclext.inc}
end.

55
components/lclextensions/lclextensions_package.lpk Executable file
View File

@ -0,0 +1,55 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="4">
<Name Value="lclextensions_package"/>
<AddToProjectUsesSection Value="True"/>
<Author Value="Luiz Americo Pereira Câmara"/>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<IncludeFiles Value="include/$(LCLWidgetType)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)-$(LCLWidgetType)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="LCL Extensions provides additional functions to be used together with LCL
"/>
<License Value="Modified LGPL
"/>
<Version Minor="5" Release="1"/>
<Files Count="3">
<Item1>
<Filename Value="delphicompat.pas"/>
<UnitName Value="DelphiCompat"/>
</Item1>
<Item2>
<Filename Value="oleutils.pas"/>
<UnitName Value="oleutils"/>
</Item2>
<Item3>
<Filename Value="lclext.pas"/>
<UnitName Value="LclExt"/>
</Item3>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>
</CONFIG>

20
components/lclextensions/lclextensions_package.pas Executable file
View File

@ -0,0 +1,20 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit lclextensions_package;
interface
uses
DelphiCompat, oleutils, LclExt, LazarusPackageIntf;
implementation
procedure Register;
begin
end;
initialization
RegisterPackage('lclextensions_package', @Register);
end.

149
components/lclextensions/oleutils.pas Executable file
View File

@ -0,0 +1,149 @@
unit oleutils;
{ OLE helper functions
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.
}
//todo: add error handling
{$mode objfpc}{$H+}
interface
{$ifdef Windows}
uses
Windows, Classes, SysUtils, ActiveX;
type
{ TOLEStream }
TOLEStream = class (TStream)
private
FSrcStream: IStream;
procedure InternalSetSize(NewSize: LARGE_INTEGER);
public
constructor Create(const Stream: IStream);
function Read(var Buffer; Count: Integer): Integer; override;
function Seek(Offset: Integer; Origin: Word): Integer; overload; override;
procedure SetSize(const NewSize: Int64); override;
procedure SetSize(NewSize: Longint); override;
function Write(const Buffer; Count: Integer): Integer; override;
end;
{$endif}
implementation
{$ifdef Windows}
function ErrorString(Error: HRESULT): String;
begin
case Error of
E_PENDING: Result:='E_PENDING';
S_FALSE: Result:='S_FALSE';
STG_E_MEDIUMFULL: Result:='STG_E_MEDIUMFULL';
STG_E_ACCESSDENIED: Result:= 'STG_E_ACCESSDENIED';
STG_E_CANTSAVE: Result:='STG_E_CANTSAVE';
STG_E_INVALIDPOINTER: Result:='STG_E_INVALIDPOINTER';
STG_E_REVERTED: Result:='STG_E_REVERTED';
STG_E_WRITEFAULT: Result:='STG_E_WRITEFAULT';
STG_E_INVALIDFUNCTION: Result:='STG_E_INVALIDFUNCTION';
else
Result:='Unknow error';
end;
end;
{ TOLEStream }
constructor TOLEStream.Create(const Stream: IStream);
begin
inherited Create;
FSrcStream:=Stream;
end;
function TOLEStream.Read(var Buffer; Count: Integer): Integer;
var
Res: HRESULT;
begin
Res:=FSrcStream.Read(@Buffer, Count, @Result);
if Res <> S_OK then
Raise Exception.Create('TOLEStream - Error while reading: '+ErrorString(Res));
end;
function TOLEStream.Seek(Offset: Integer; Origin: Word): Integer;
var
liResult, liOffset : LARGE_INTEGER;
Res: HRESULT;
begin
//soFrom* constants are equal to STREAM_SEEK_* constants. Assume it here
liOffset.LowPart:=Offset;
liOffset.HighPart:=0;
Res:=FSrcStream.Seek(Int64(liOffset), Origin, Int64(liResult));
Result:=liResult.LowPart;
if Res <> S_OK then
Raise Exception.Create('TOLEStream - Error while seeking: '+ErrorString(Res));
end;
procedure TOLEStream.SetSize(NewSize: Longint);
var
liSize: LARGE_INTEGER;
begin
liSize.LowPart:=NewSize;
liSize.HighPart:=0;
InternalSetSize(liSize);
end;
procedure TOLEStream.SetSize(const NewSize: Int64);
var
liSize: LARGE_INTEGER;
begin
liSize.QuadPart:=NewSize;
InternalSetSize(liSize);
end;
procedure TOLEStream.InternalSetSize(NewSize: LARGE_INTEGER);
var
Res:HRESULT;
begin
Res:=FSrcStream.SetSize(Int64(NewSize));
if Res <> S_OK then
Raise Exception.Create('TOLEStream - Error while setting size: '+ErrorString(Res));
end;
function TOLEStream.Write(const Buffer; Count: Integer): Integer;
var
Res: HRESULT;
begin
Res:=FSrcStream.Write(@Buffer,Count,@Result);
if Res <> S_OK then
Raise Exception.Create('TOLEStream - Error while writing: '+ErrorString(Res));
end;
{$endif}
end.

135
components/lclextensions/tests/settimer/Unit1.lfm Executable file
View File

@ -0,0 +1,135 @@
object MainForm: TMainForm
Left = 409
Height = 448
Top = 218
Width = 613
HorzScrollBar.Page = 559
VertScrollBar.Page = 447
ActiveControl = ListBox1
Caption = 'Test SetTimer'
ClientHeight = 448
ClientWidth = 613
Position = poScreenCenter
LCLVersion = '1.1'
object ListBox1: TListBox
Left = 8
Height = 403
Top = 8
Width = 320
Anchors = [akTop, akLeft, akBottom]
ItemHeight = 0
ScrollWidth = 318
TabOrder = 0
TopIndex = -1
end
object Button1: TButton
Left = 240
Height = 30
Top = 414
Width = 88
Anchors = [akLeft, akBottom]
BorderSpacing.InnerBorder = 4
Caption = 'Clear'
OnClick = Button1Click
TabOrder = 1
end
object SetTimer1Button: TButton
Left = 345
Height = 28
Top = 8
Width = 120
BorderSpacing.InnerBorder = 4
Caption = 'Set Timer 1'
OnClick = SetTimer1ButtonClick
TabOrder = 2
end
object SetTimer2Button: TButton
Left = 345
Height = 28
Top = 48
Width = 120
BorderSpacing.InnerBorder = 4
Caption = 'Set Timer 2'
OnClick = SetTimer2ButtonClick
TabOrder = 3
end
object SetTimer3Button: TButton
Left = 345
Height = 28
Top = 88
Width = 120
BorderSpacing.InnerBorder = 4
Caption = 'Set Timer 3'
OnClick = SetTimer3ButtonClick
TabOrder = 4
end
object KillTimer1Button: TButton
Left = 481
Height = 28
Top = 8
Width = 120
BorderSpacing.InnerBorder = 4
Caption = 'Kill'
OnClick = KillTimer1ButtonClick
TabOrder = 5
end
object KillTimer2Button: TButton
Left = 481
Height = 28
Top = 48
Width = 120
BorderSpacing.InnerBorder = 4
Caption = 'Kill'
OnClick = KillTimer2ButtonClick
TabOrder = 6
end
object KillTimer3Button: TButton
Left = 481
Height = 60
Top = 88
Width = 120
BorderSpacing.InnerBorder = 4
Caption = 'Kill'
OnClick = KillTimer3ButtonClick
TabOrder = 7
end
object SetTimer3bButton: TButton
Left = 345
Height = 28
Top = 120
Width = 120
BorderSpacing.InnerBorder = 4
Caption = 'Set Timer 3b'
OnClick = SetTimer3bButtonClick
TabOrder = 8
end
object SetTimerDestroyButton: TButton
Left = 345
Height = 28
Top = 224
Width = 256
Caption = 'Set Timer and Destroy'
OnClick = SetTimerDestroyButtonClick
TabOrder = 9
end
object SetGlobalTimerButton: TButton
Left = 345
Height = 28
Top = 160
Width = 120
BorderSpacing.InnerBorder = 4
Caption = 'Set Global Timer'
OnClick = SetGlobalTimerButtonClick
TabOrder = 10
end
object KillGlobalTimerButton1: TButton
Left = 481
Height = 28
Top = 160
Width = 120
BorderSpacing.InnerBorder = 4
Caption = 'Kill'
OnClick = KillGlobalTimerButton1Click
TabOrder = 11
end
end

183
components/lclextensions/tests/settimer/Unit1.pas Executable file
View File

@ -0,0 +1,183 @@
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
Buttons, delphicompat, LMessages, LCLType;
type
{ TMainForm }
TMainForm = class(TForm)
Button1: TButton;
KillGlobalTimerButton1: TButton;
SetGlobalTimerButton: TButton;
SetTimerDestroyButton: TButton;
SetTimer1Button: TButton;
SetTimer2Button: TButton;
SetTimer3Button: TButton;
KillTimer1Button: TButton;
KillTimer2Button: TButton;
KillTimer3Button: TButton;
SetTimer3bButton: TButton;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
procedure KillGlobalTimerButton1Click(Sender: TObject);
procedure SetGlobalTimerButtonClick(Sender: TObject);
procedure SetTimer1ButtonClick(Sender: TObject);
procedure SetTimer2ButtonClick(Sender: TObject);
procedure SetTimer3ButtonClick(Sender: TObject);
procedure KillTimer1ButtonClick(Sender: TObject);
procedure KillTimer2ButtonClick(Sender: TObject);
procedure KillTimer3ButtonClick(Sender: TObject);
procedure SetTimer3bButtonClick(Sender: TObject);
procedure SetTimerDestroyButtonClick(Sender: TObject);
protected
procedure WMTimer(var Message: TLMTimer); message LM_TIMER;
private
FGlobalTimer: PtrUInt;
procedure TimerCallback(AId: PtrUInt);
procedure TimerCallbackGlobal(AId: PtrUInt);
procedure TimerCallbackOther(AId: PtrUInt);
{ private declarations }
public
{ public declarations }
end;
var
MainForm: TMainForm;
implementation
uses
strutils;
const
Timer1 = 1;
Timer2 = 2;
Timer3 = 3;
{ TMainForm }
procedure TMainForm.Button1Click(Sender: TObject);
begin
ListBox1.Clear;
end;
procedure TMainForm.KillGlobalTimerButton1Click(Sender: TObject);
begin
if FGlobalTimer <> 0 then
begin
KillTimer(0, FGlobalTimer);
FGlobalTimer := 0;
end;
end;
procedure TMainForm.SetGlobalTimerButtonClick(Sender: TObject);
begin
FGlobalTimer := SetTimer(0,FGlobalTimer,2000,@TimerCallbackGlobal);
end;
procedure TMainForm.SetTimer1ButtonClick(Sender: TObject);
begin
SetTimer(Handle,Timer1,1000,nil);
end;
procedure TMainForm.SetTimer2ButtonClick(Sender: TObject);
begin
SetTimer(Handle,Timer2,2000,nil);
end;
procedure TMainForm.SetTimer3ButtonClick(Sender: TObject);
begin
SetTimer(Handle,Timer3,3000,@TimerCallback);
end;
procedure TMainForm.KillTimer1ButtonClick(Sender: TObject);
begin
KillTimer(Handle,Timer1);
end;
procedure TMainForm.KillTimer2ButtonClick(Sender: TObject);
begin
KillTimer(Handle,Timer2);
end;
procedure TMainForm.KillTimer3ButtonClick(Sender: TObject);
begin
KillTimer(Handle,Timer3);
end;
procedure TMainForm.SetTimer3bButtonClick(Sender: TObject);
begin
SetTimer(Handle,Timer3,3000,@TimerCallbackOther);
end;
type
{ TMyButton }
TMyButton = class(TButton)
protected
procedure WMTimer(var Message: TLMTimer); message LM_TIMER;
end;
{ TMyButton }
procedure TMyButton.WMTimer(var Message: TLMTimer);
begin
MainForm.ListBox1.Items.Add('WMTimer - Released Button (Should Not Be Fired)');
end;
procedure TMainForm.SetTimerDestroyButtonClick(Sender: TObject);
var
Button: TButton;
begin
Button := TButton.Create(nil);
try
Button.Parent := Self;
Button.Visible := True;
SetTimer(Button.Handle, Timer3, 1000, nil);
finally
Button.Destroy;
end;
end;
procedure TMainForm.WMTimer(var Message: TLMTimer);
var
AStr: String;
begin
case Message.TimerID of
Timer1: AStr:='Timer1 called';
Timer2: AStr:='Timer2 called';
Timer3: AStr:='Timer3 called';
else
AStr:='TimerID not identified: '+IntToStr(Message.TimerID);
end;
ListBox1.Items.Add('WMTimer - '+AStr);
end;
procedure TMainForm.TimerCallback(AId: PtrUInt);
begin
ListBox1.Items.Add('TimerCallback called');
end;
procedure TMainForm.TimerCallbackGlobal(AId: PtrUInt);
begin
ListBox1.Items.Add('TimerCallbackGlobal called' + IfThen(AId <> FGlobalTimer, ' ERROR: ID <> GlobalTimer'));
end;
procedure TMainForm.TimerCallbackOther(AId: PtrUInt);
begin
ListBox1.Items.Add('TimerCallbackOther called');
end;
initialization
{$I Unit1.lrs}
end.

87
components/lclextensions/tests/settimer/project1.lpi Executable file
View File

@ -0,0 +1,87 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<Flags>
<LRSInOutputDirectory Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<UseXPManifest Value="True"/>
</General>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="lclextensions_package"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="project1"/>
</Unit0>
<Unit1>
<Filename Value="Unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="MainForm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="testsettimer"/>
</Target>
<SearchPaths>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
<Linking>
<Debugging>
<UseHeaptrc Value="True"/>
</Debugging>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="2">
<Item1>
<Name Value="ECodetoolError"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
</Item2>
</Exceptions>
</Debugging>
</CONFIG>

20
components/lclextensions/tests/settimer/project1.lpr Executable file
View File

@ -0,0 +1,20 @@
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms
{ add your units here }, Unit1, lclextensions_package;
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.