1 { $Id: lclintf.pas 61638 2019-07-28 10:44:39Z martin $ }
2 {
3 /***************************************************************************
4 LCLIntf.pas
5 -----------
6 Component Library Windows Controls
7 Initial Revision : Fri Jul 23 20:00:00 PDT 1999
8
9
10 ***************************************************************************/
11
12 *****************************************************************************
13 This file is part of the Lazarus Component Library (LCL)
14
15 See the file COPYING.modifiedLGPL.txt, included in this distribution,
16 for details about the license.
17 *****************************************************************************
18 }
19
20 {
21 @author(Curtis White <cwhite@aracnet.com>)
22 @created(17-Oct-1999)
23
24 This unit is being created specifically for compatibility with Delphi. It
25 contains selected functions that are included in the Delphi Windows unit.
26 These functions are mostly abstract and implemented by the LCL interfaces.
27
28 For LCL users:
29 The functions can be used to make porting of Delphi applications easier
30 and are not 100% emulating winapi functions, not even under windows. They were
31 implemented and tested with some common Delphi libraries.
32 The LCL contains many extra functions that the Delphi VCL does not have.
33 For example:
34 Instead of using the common windows functions SaveDC and RestoreDC use instead
35 the Canvas.SaveHandleState and Canvas.RestoreHandleState.
36 }
37
38 unit LCLIntf;
39
40 {$mode objfpc}{$H+}
41 {$inline on}
42
43 {$IFDEF DARWIN}
44 {$modeswitch objectivec1}
45 {$ENDIF}
46
47 interface
48
49 uses
50 {$IFDEF Windows}Windows, ShellApi, LazUtf16,{$ENDIF}
51 {$IFDEF UNIX}Unix, {$ENDIF}
52 {$IFDEF Darwin}MacOSAll, CocoaAll,{$ENDIF}
53 Math, Classes, SysUtils, Types,
54 // LCL
55 LCLType, LCLProc, LMessages, LCLStrConsts, GraphType, InterfaceBase,
56 // LazUtils
57 FileUtil, LazFileUtils, UTF8Process, LazUTF8, LazSysUtils, Maps;
58
59 {$ifdef Trace}
60 {$ASSERTIONS ON}
61 {$endif}
62 {$DEFINE ClientRectBugFix}
63
64 // All winapi related stuff (Delphi compatible)
65 {$I winapih.inc}
66 // All interface communication (Our additions)
67 {$I lclintfh.inc}
68
PredefinedClipboardFormatnull69 function PredefinedClipboardFormat(AFormat: TPredefinedClipboardFormat): TClipboardFormat;
70
MsgKeyDataToShiftStatenull71 function MsgKeyDataToShiftState(KeyData: PtrInt): TShiftState;
72
GetTickCountnull73 function GetTickCount: DWord; inline;
GetTickCount64null74 function GetTickCount64: QWord; inline;
75
76 {$IFDEF DebugLCL}
GetTickStepnull77 function GetTickStep: DWord;
78 {$ENDIF}
79
FindDefaultBrowsernull80 function FindDefaultBrowser(out ABrowser, AParams: String): Boolean;
81 // Spaces in URLs need to be encoded as %20 Read http://www.ietf.org/rfc/rfc1738.txt
OpenURLnull82 function OpenURL(AURL: String): Boolean;
OpenDocumentnull83 function OpenDocument(APath: String): Boolean;
84
85 type
86 TOpenParamStringProc = function (AString: string): Boolean of object;
87
88 var
89 OnShowSelectItemDialogResult: TOnShowSelectItemDialogResult = nil;
90 OnListViewDialogResult: TOnShowSelectItemDialogResult = nil; // -1 in the position indicates the dialog was cancelled
91
92 OpenURLWidgetsetImplementation: TOpenParamStringProc = nil;
93 OpenDocumentWidgetsetImplementation: TOpenParamStringProc = nil;
94
95 implementation
96
97 type
98 { TTimerID }
99
100 TTimerID = class
101 procedure TimerNotify;
102 end;
103
104 PTimerInfo = ^TTimerInfo;
105 TTimerInfo = record
106 Wnd: HWND;
107 IDEvent: UINT_PTR;
108 TimerProc: TTimerProc;
109 Handle: THandle;
110 end;
111
112 var
113 MTimerMap: TMap = nil; // hWnd + nIDEvent -> ID
114 MTimerInfo: TMap = nil; // ID -> TTimerInfo
115 MTimerSeq: Cardinal;
116
117 FPredefinedClipboardFormats:
118 array[TPredefinedClipboardFormat] of TClipboardFormat;
119 LowerCaseChars: array[char] of char;
120 UpperCaseChars: array[char] of char;
121
122
123 { TTimerMap }
124
125 procedure TTimerID.TimerNotify;
126 var
127 Info: PTimerInfo;
128 ID: Cardinal;
129 begin
130 if MTimerInfo = nil then Exit;
131
132 // this is a bit of a hack.
133 // to pass the ID if the timer, it is passed as an cast to self
134 // So there isn't realy an instance of TTimerID
135 ID := PtrUInt(Self);
136 Info := MTimerInfo.GetDataPtr(ID);
137 if Info = nil then Exit;
138
139 if Info^.TimerProc = nil
140 then begin
141 // send message
142 PostMessage(Info^.Wnd, LM_TIMER, Info^.IDEvent, 0);
143 end
144 else begin
145 // a timerproc was passed
146 Info^.TimerProc(Info^.Wnd, LM_TIMER, Info^.IDEvent, GetTickCount);
147 end;
148 end;
149
150 function GetTickCount(): DWord;
151 begin
152 Result := DWord(LazSysUtils.GetTickCount64());
153 end;
154
155 function GetTickCount64(): QWord;
156 begin
157 Result := LazSysUtils.GetTickCount64();
158 end;
159
160 {$IFDEF DebugLCL}
161 var
162 LastTickValid: boolean;
163 LastTick: DWord;
164
165 function GetTickStep: DWord;
166 var
167 CurTick: DWord;
168 begin
169 CurTick:=GetTickCount;
170 if LastTickValid then begin
171 if LastTick<=CurTick then
172 Result:=CurTick-LastTick
173 else begin
174 // tick counter has restarted
175 Result:=CurTick+(DWord($FFFFFFFF)-LastTick+1);
176 end;
177 end else begin
178 Result:=0;
179 end;
180 LastTickValid:=true;
181 LastTick:=CurTick;
182 end;
183 {$ENDIF}
184
185
186 function PredefinedClipboardFormat(AFormat: TPredefinedClipboardFormat): TClipboardFormat;
187 begin
188 if FPredefinedClipboardFormats[AFormat]=0 then begin
189 if WidgetSet=nil then
190 raise Exception.Create(rsNoWidgetSet);
191 FPredefinedClipboardFormats[AFormat]:=
192 ClipboardRegisterFormat(PredefinedClipboardMimeTypes[AFormat]);
193 end;
194 Result:=FPredefinedClipboardFormats[AFormat];
195 end;
196
197 function MsgKeyDataToShiftState(KeyData: PtrInt): TShiftState;
198 begin
199 Result := [];
200
201 if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
202 if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
203 if GetKeyState(VK_LWIN) < 0 then Include(Result, ssMeta);
204 if KeyData and MK_ALT <> 0 then Include(Result, ssAlt);
205 end;
206
207 {$I winapi.inc}
208 {$I lclintf.inc}
209
210 // System APIs which have an operating-system specific implementation
211 // They should be moved to FPC eventually
212 {$I sysenvapis.inc}
213 {$IFDEF Windows}
214 {$I sysenvapis_win.inc}
215 {$ENDIF}
216 {$IFDEF HASAMIGA}
217 {$I sysenvapis_amiga.inc}
218 {$ENDIF}
219 {$IFDEF UNIX}
220 {$IFDEF darwin}
221 {$I sysenvapis_mac.inc}
222 {$ELSE}
223 {$I sysenvapis_unix.inc}
224 {$ENDIF}
225 {$ENDIF}
226
227 procedure InternalInit;
228 var
229 AClipboardFormat: TPredefinedClipboardFormat;
230 c: char;
231 s: string;
232 begin
233 for AClipboardFormat:=Low(TPredefinedClipboardFormat) to
234 High(TPredefinedClipboardFormat) do
235 FPredefinedClipboardFormats[AClipboardFormat]:=0;
236 for c:=Low(char) to High(char) do begin
237 s:=lowercase(c);
238 LowerCaseChars[c]:=s[1];
239 UpperCaseChars[c]:=upcase(c);
240 end;
241 {$IFDEF DebugLCL}
242 LastTickValid:=false;
243 {$ENDIF}
244 end;
245
246 initialization
247 InternalInit;
248
249 finalization
250 FreeAndNil(MTimerMap);
251 FreeAndNil(MTimerInfo);
252 end.
253