My favorites | Sign in
Project Home Issues Source
Checkout   Browse   Changes  
Changes to /trunk/source/helpers.pas
r4143 vs. r4144 Compare: vs.  Format:
Revision r4144
Go to: 
/trunk/source/helpers.pas   r4143 /trunk/source/helpers.pas   r4144
1 unit helpers; 1 unit helpers;
2 2
3 3
4 // ------------------------------------- 4 // -------------------------------------
5 // Functions-library 5 // Functions-library
6 // ------------------------------------- 6 // -------------------------------------
7 7
8 8
9 interface 9 interface
10 10
11 uses 11 uses
12 Classes, SysUtils, Graphics, GraphUtil, ClipBrd, Dialogs, Forms, Controls, ShellApi, 12 Classes, SysUtils, Graphics, GraphUtil, ClipBrd, Dialogs, Forms, Controls, ShellApi,
13 Windows, ShlObj, ActiveX, VirtualTrees, SynRegExpr, Messages, Math, 13 Windows, ShlObj, ActiveX, VirtualTrees, SynRegExpr, Messages, Math,
14 Registry, DateUtils, Generics.Collections, StrUtils, AnsiStrings, TlHelp32, Types, 14 Registry, DateUtils, Generics.Collections, StrUtils, AnsiStrings, TlHelp32, Types,
15 dbconnection, mysql_structures, SynMemo, Menus, WinInet; 15 dbconnection, mysql_structures, SynMemo, Menus, WinInet;
16 16
17 type 17 type
18 18
19 TOrderCol = class(TObject) 19 TOrderCol = class(TObject)
20 ColumnName: String; 20 ColumnName: String;
21 SortDirection: Byte; 21 SortDirection: Byte;
22 end; 22 end;
23 TOrderColArray = Array of TOrderCol; 23 TOrderColArray = Array of TOrderCol;
24 24
25 TLineBreaks = (lbsNone, lbsWindows, lbsUnix, lbsMac, lbsWide, lbsMixed); 25 TLineBreaks = (lbsNone, lbsWindows, lbsUnix, lbsMac, lbsWide, lbsMixed);
26 26
27 TDBObjectEditor = class(TFrame) 27 TDBObjectEditor = class(TFrame)
28 private 28 private
29 FModified: Boolean; 29 FModified: Boolean;
30 FDefiners: TStringList; 30 FDefiners: TStringList;
31 procedure SetModified(Value: Boolean); 31 procedure SetModified(Value: Boolean);
32 protected 32 protected
33 public 33 public
34 DBObject: TDBObject; 34 DBObject: TDBObject;
35 constructor Create(AOwner: TComponent); override; 35 constructor Create(AOwner: TComponent); override;
36 destructor Destroy; override; 36 destructor Destroy; override;
37 procedure Init(Obj: TDBObject); virtual; 37 procedure Init(Obj: TDBObject); virtual;
38 function DeInit: TModalResult; 38 function DeInit: TModalResult;
39 function GetDefiners: TStringList; 39 function GetDefiners: TStringList;
40 property Modified: Boolean read FModified write SetModified; 40 property Modified: Boolean read FModified write SetModified;
41 function ApplyModifications: TModalResult; virtual; abstract; 41 function ApplyModifications: TModalResult; virtual; abstract;
42 end; 42 end;
43 TDBObjectEditorClass = class of TDBObjectEditor; 43 TDBObjectEditorClass = class of TDBObjectEditor;
44 44
45 TWndProc = function (hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; 45 TWndProc = function (hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
46 PGripInfo = ^TGripInfo; 46 PGripInfo = ^TGripInfo;
47 TGripInfo = record 47 TGripInfo = record
48 OldWndProc: TWndProc; 48 OldWndProc: TWndProc;
49 Enabled: boolean; 49 Enabled: boolean;
50 GripRect: TRect; 50 GripRect: TRect;
51 end; 51 end;
52 52
53 TSQLBatch = class; 53 TSQLBatch = class;
54 TSQLSentence = class(TObject) 54 TSQLSentence = class(TObject)
55 private 55 private
56 FOwner: TSQLBatch; 56 FOwner: TSQLBatch;
57 function GetSize: Integer; 57 function GetSize: Integer;
58 function GetSQL: String; 58 function GetSQL: String;
59 public 59 public
60 LeftOffset, RightOffset: Integer; 60 LeftOffset, RightOffset: Integer;
61 constructor Create(Owner: TSQLBatch); 61 constructor Create(Owner: TSQLBatch);
62 property SQL: String read GetSQL; 62 property SQL: String read GetSQL;
63 property Size: Integer read GetSize; 63 property Size: Integer read GetSize;
64 end; 64 end;
65 TSQLBatch = class(TObjectList<TSQLSentence>) 65 TSQLBatch = class(TObjectList<TSQLSentence>)
66 private 66 private
67 FSQL: String; 67 FSQL: String;
68 procedure SetSQL(Value: String); 68 procedure SetSQL(Value: String);
69 function GetSize: Integer; 69 function GetSize: Integer;
70 public 70 public
71 property Size: Integer read GetSize; 71 property Size: Integer read GetSize;
72 property SQL: String read FSQL write SetSQL; 72 property SQL: String read FSQL write SetSQL;
73 end; 73 end;
74 74
75 // Download 75 // Download
76 THttpDownload = class(TObject) 76 THttpDownload = class(TObject)
77 private 77 private
78 FOwner: TComponent; 78 FOwner: TComponent;
79 FURL: String; 79 FURL: String;
80 FBytesRead: Integer; 80 FBytesRead: Integer;
81 FContentLength: Integer; 81 FContentLength: Integer;
82 FOnProgress: TNotifyEvent; 82 FOnProgress: TNotifyEvent;
83 public 83 public
84 constructor Create(Owner: TComponent); 84 constructor Create(Owner: TComponent);
85 procedure SendRequest(Filename: String); 85 procedure SendRequest(Filename: String);
86 property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; 86 property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
87 property URL: String read FURL write FURL; 87 property URL: String read FURL write FURL;
88 property BytesRead: Integer read FBytesRead; 88 property BytesRead: Integer read FBytesRead;
89 property ContentLength: Integer read FContentLength; 89 property ContentLength: Integer read FContentLength;
90 end; 90 end;
91 91
92 // Threading stuff 92 // Threading stuff
93 TQueryThread = class(TThread) 93 TQueryThread = class(TThread)
94 private 94 private
95 FConnection: TDBConnection; 95 FConnection: TDBConnection;
96 FBatch: TSQLBatch; 96 FBatch: TSQLBatch;
97 FTabNumber: Integer; 97 FTabNumber: Integer;
98 FBatchInOneGo: Boolean; 98 FBatchInOneGo: Boolean;
99 FStopOnErrors: Boolean; 99 FStopOnErrors: Boolean;
100 FAborted: Boolean; 100 FAborted: Boolean;
101 FErrorMessage: String; 101 FErrorMessage: String;
102 FBatchPosition: Integer; 102 FBatchPosition: Integer;
103 FQueriesInPacket: Integer; 103 FQueriesInPacket: Integer;
104 FQueryTime: Cardinal; 104 FQueryTime: Cardinal;
105 FQueryNetTime: Cardinal; 105 FQueryNetTime: Cardinal;
106 FRowsAffected: Int64; 106 FRowsAffected: Int64;
107 FRowsFound: Int64; 107 FRowsFound: Int64;
108 FWarningCount: Int64; 108 FWarningCount: Int64;
109 FLogMsg: String; 109 FLogMsg: String;
110 FLogCategory: TDBLogCategory; 110 FLogCategory: TDBLogCategory;
111 procedure BeforeQuery; 111 procedure BeforeQuery;
112 procedure AfterQuery; 112 procedure AfterQuery;
113 procedure BatchFinished; 113 procedure BatchFinished;
114 procedure Log; 114 procedure Log;
115 public 115 public
116 property Connection: TDBConnection read FConnection; 116 property Connection: TDBConnection read FConnection;
117 property Batch: TSQLBatch read FBatch; 117 property Batch: TSQLBatch read FBatch;
118 property TabNumber: Integer read FTabNumber; 118 property TabNumber: Integer read FTabNumber;
119 property BatchPosition: Integer read FBatchPosition; 119 property BatchPosition: Integer read FBatchPosition;
120 property QueriesInPacket: Integer read FQueriesInPacket; 120 property QueriesInPacket: Integer read FQueriesInPacket;
121 property QueryTime: Cardinal read FQueryTime; 121 property QueryTime: Cardinal read FQueryTime;
122 property QueryNetTime: Cardinal read FQueryNetTime; 122 property QueryNetTime: Cardinal read FQueryNetTime;
123 property RowsAffected: Int64 read FRowsAffected; 123 property RowsAffected: Int64 read FRowsAffected;
124 property RowsFound: Int64 read FRowsFound; 124 property RowsFound: Int64 read FRowsFound;
125 property WarningCount: Int64 read FWarningCount; 125 property WarningCount: Int64 read FWarningCount;
126 property Aborted: Boolean read FAborted write FAborted; 126 property Aborted: Boolean read FAborted write FAborted;
127 property ErrorMessage: String read FErrorMessage; 127 property ErrorMessage: String read FErrorMessage;
128 constructor Create(Connection: TDBConnection; Batch: TSQLBatch; TabNumber: Integer); 128 constructor Create(Connection: TDBConnection; Batch: TSQLBatch; TabNumber: Integer);
129 procedure Execute; override; 129 procedure Execute; override;
130 procedure LogFromOutside(Msg: String; Category: TDBLogCategory); 130 procedure LogFromOutside(Msg: String; Category: TDBLogCategory);
131 end; 131 end;
132 132
133 133
134 134
135 {$I const.inc} 135 {$I const.inc}
136 136
137 function implodestr(seperator: String; a: TStrings) :String; 137 function implodestr(seperator: String; a: TStrings) :String;
138 function Explode(Separator, Text: String) :TStringList; 138 function Explode(Separator, Text: String) :TStringList;
139 procedure ExplodeQuotedList(Text: String; var List: TStringList); 139 procedure ExplodeQuotedList(Text: String; var List: TStringList);
140 function RemoveComments(SQL: String): String; 140 function RemoveComments(SQL: String): String;
141 function sstr(str: String; len: Integer) : String; 141 function sstr(str: String; len: Integer) : String;
142 function encrypt(str: String): String; 142 function encrypt(str: String): String;
143 function decrypt(str: String): String; 143 function decrypt(str: String): String;
144 function htmlentities(str: String): String; 144 function htmlentities(str: String): String;
145 function BestTableName(Data: TDBQuery): String; 145 function BestTableName(Data: TDBQuery): String;
146 function EncodeURL(const Src: String): String; 146 function EncodeURL(const Src: String): String;
147 procedure StreamWrite(S: TStream; Text: String = ''); 147 procedure StreamWrite(S: TStream; Text: String = '');
148 function _GetFileSize(Filename: String): Int64; 148 function _GetFileSize(Filename: String): Int64;
149 function MakeInt( Str: String ) : Int64; 149 function MakeInt( Str: String ) : Int64;
150 function MakeFloat( Str: String ): Extended; 150 function MakeFloat( Str: String ): Extended;
151 function CleanupNumber(Str: String): String; 151 function CleanupNumber(Str: String): String;
152 function IsNumeric(Str: String): Boolean;
152 function esc(Text: String; ProcessJokerChars: Boolean=false; DoQuote: Boolean=True): String; 153 function esc(Text: String; ProcessJokerChars: Boolean=false; DoQuote: Boolean=True): String;
153 function ScanNulChar(Text: String): Boolean; 154 function ScanNulChar(Text: String): Boolean;
154 function ScanLineBreaks(Text: String): TLineBreaks; 155 function ScanLineBreaks(Text: String): TLineBreaks;
155 function RemoveNulChars(Text: String): String; 156 function RemoveNulChars(Text: String): String;
156 function fixNewlines(txt: String): String; 157 function fixNewlines(txt: String): String;
157 function GetShellFolder(CSIDL: integer): string; 158 function GetShellFolder(CSIDL: integer): string;
158 function goodfilename( str: String ): String; 159 function goodfilename( str: String ): String;
159 function FormatNumber( str: String; Thousands: Boolean=True): String; Overload; 160 function FormatNumber( str: String; Thousands: Boolean=True): String; Overload;
160 function UnformatNumber(Val: String): String; 161 function UnformatNumber(Val: String): String;
161 function FormatNumber( int: Int64; Thousands: Boolean=True): String; Overload; 162 function FormatNumber( int: Int64; Thousands: Boolean=True): String; Overload;
162 function FormatNumber( flt: Double; decimals: Integer = 0; Thousands: Boolean=True): String; Overload; 163 function FormatNumber( flt: Double; decimals: Integer = 0; Thousands: Boolean=True): String; Overload;
163 procedure setLocales; 164 procedure setLocales;
164 procedure ShellExec(cmd: String; path: String=''; params: String=''); 165 procedure ShellExec(cmd: String; path: String=''; params: String='');
165 function getFirstWord( text: String ): String; 166 function getFirstWord( text: String ): String;
166 function FormatByteNumber( Bytes: Int64; Decimals: Byte = 1 ): String; Overload; 167 function FormatByteNumber( Bytes: Int64; Decimals: Byte = 1 ): String; Overload;
167 function FormatByteNumber( Bytes: String; Decimals: Byte = 1 ): String; Overload; 168 function FormatByteNumber( Bytes: String; Decimals: Byte = 1 ): String; Overload;
168 function FormatTimeNumber(Seconds: Cardinal; DisplaySeconds: Boolean): String; 169 function FormatTimeNumber(Seconds: Cardinal; DisplaySeconds: Boolean): String;
169 function GetTempDir: String; 170 function GetTempDir: String;
170 procedure SetWindowSizeGrip(hWnd: HWND; Enable: boolean); 171 procedure SetWindowSizeGrip(hWnd: HWND; Enable: boolean);
171 procedure SaveUnicodeFile(Filename: String; Text: String); 172 procedure SaveUnicodeFile(Filename: String; Text: String);
172 procedure OpenTextFile(const Filename: String; out Stream: TFileStream; var Encoding: TEncoding); 173 procedure OpenTextFile(const Filename: String; out Stream: TFileStream; var Encoding: TEncoding);
173 function DetectEncoding(Stream: TStream): TEncoding; 174 function DetectEncoding(Stream: TStream): TEncoding;
174 function ReadTextfileChunk(Stream: TFileStream; Encoding: TEncoding; ChunkSize: Int64 = 0): String; 175 function ReadTextfileChunk(Stream: TFileStream; Encoding: TEncoding; ChunkSize: Int64 = 0): String;
175 function ReadTextfile(Filename: String; Encoding: TEncoding): String; 176 function ReadTextfile(Filename: String; Encoding: TEncoding): String;
176 function ReadBinaryFile(Filename: String; MaxBytes: Int64): AnsiString; 177 function ReadBinaryFile(Filename: String; MaxBytes: Int64): AnsiString;
177 procedure StreamToClipboard(Text, HTML: TStream; CreateHTMLHeader: Boolean); 178 procedure StreamToClipboard(Text, HTML: TStream; CreateHTMLHeader: Boolean);
178 function WideHexToBin(text: String): AnsiString; 179 function WideHexToBin(text: String): AnsiString;
179 function BinToWideHex(bin: AnsiString): String; 180 function BinToWideHex(bin: AnsiString): String;
180 procedure FixVT(VT: TVirtualStringTree; MultiLineCount: Word=1); 181 procedure FixVT(VT: TVirtualStringTree; MultiLineCount: Word=1);
181 function GetTextHeight(Font: TFont): Integer; 182 function GetTextHeight(Font: TFont): Integer;
182 function ColorAdjustBrightness(Col: TColor; Shift: SmallInt): TColor; 183 function ColorAdjustBrightness(Col: TColor; Shift: SmallInt): TColor;
183 function ComposeOrderClause(Cols: TOrderColArray): String; 184 function ComposeOrderClause(Cols: TOrderColArray): String;
184 procedure OpenRegistry(Session: String = ''); 185 procedure OpenRegistry(Session: String = '');
185 function GetRegValue( valueName: String; defaultValue: Integer; Session: String = '' ) : Integer; Overload; 186 function GetRegValue( valueName: String; defaultValue: Integer; Session: String = '' ) : Integer; Overload;
186 function GetRegValue( valueName: String; defaultValue: Boolean; Session: String = '' ) : Boolean; Overload; 187 function GetRegValue( valueName: String; defaultValue: Boolean; Session: String = '' ) : Boolean; Overload;
187 function GetRegValue( valueName: String; defaultValue: String; Session: String = '' ) : String; Overload; 188 function GetRegValue( valueName: String; defaultValue: String; Session: String = '' ) : String; Overload;
188 procedure DeInitializeVTNodes(Sender: TBaseVirtualTree); 189 procedure DeInitializeVTNodes(Sender: TBaseVirtualTree);
189 function ListIndexByRegExpr(List: TStrings; Expression: String): Integer; 190 function ListIndexByRegExpr(List: TStrings; Expression: String): Integer;
190 function FindNode(VT: TVirtualStringTree; idx: Cardinal; ParentNode: PVirtualNode): PVirtualNode; 191 function FindNode(VT: TVirtualStringTree; idx: Cardinal; ParentNode: PVirtualNode): PVirtualNode;
191 procedure SelectNode(VT: TVirtualStringTree; idx: Cardinal; ParentNode: PVirtualNode=nil); overload; 192 procedure SelectNode(VT: TVirtualStringTree; idx: Cardinal; ParentNode: PVirtualNode=nil); overload;
192 procedure SelectNode(VT: TVirtualStringTree; Node: PVirtualNode); overload; 193 procedure SelectNode(VT: TVirtualStringTree; Node: PVirtualNode); overload;
193 function GetVTSelection(VT: TVirtualStringTree): TStringList; 194 function GetVTSelection(VT: TVirtualStringTree): TStringList;
194 procedure SetVTSelection(VT: TVirtualStringTree; Captions: TStringList); 195 procedure SetVTSelection(VT: TVirtualStringTree; Captions: TStringList);
195 function GetNextNode(Tree: TVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode; 196 function GetNextNode(Tree: TVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode;
196 function DateBackFriendlyCaption(d: TDateTime): String; 197 function DateBackFriendlyCaption(d: TDateTime): String;
197 procedure InheritFont(AFont: TFont); 198 procedure InheritFont(AFont: TFont);
198 function GetLightness(AColor: TColor): Byte; 199 function GetLightness(AColor: TColor): Byte;
199 function ReformatSQL(SQL: String): String; 200 function ReformatSQL(SQL: String): String;
200 function ParamBlobToStr(lpData: Pointer): TStringlist; 201 function ParamBlobToStr(lpData: Pointer): TStringlist;
201 function ParamStrToBlob(out cbData: DWORD): Pointer; 202 function ParamStrToBlob(out cbData: DWORD): Pointer;
202 function CheckForSecondInstance: Boolean; 203 function CheckForSecondInstance: Boolean;
203 function GetParentFormOrFrame(Comp: TWinControl): TWinControl; 204 function GetParentFormOrFrame(Comp: TWinControl): TWinControl;
204 function GetIndexIcon(IndexType: String): Integer; 205 function GetIndexIcon(IndexType: String): Integer;
205 function KeyPressed(Code: Integer): Boolean; 206 function KeyPressed(Code: Integer): Boolean;
206 function GeneratePassword(Len: Integer): String; 207 function GeneratePassword(Len: Integer): String;
207 procedure InvalidateVT(VT: TVirtualStringTree; RefreshTag: Integer; ImmediateRepaint: Boolean); 208 procedure InvalidateVT(VT: TVirtualStringTree; RefreshTag: Integer; ImmediateRepaint: Boolean);
208 procedure HandlePortableSettings(StartupMode: Boolean); 209 procedure HandlePortableSettings(StartupMode: Boolean);
209 procedure ImportSettings(Filename: String); 210 procedure ImportSettings(Filename: String);
210 procedure ExportSettings(Filename: String); 211 procedure ExportSettings(Filename: String);
211 function CharAtPos(Str: String; Pos: Integer): Char; 212 function CharAtPos(Str: String; Pos: Integer): Char;
212 function CompareAnyNode(Text1, Text2: String): Integer; 213 function CompareAnyNode(Text1, Text2: String): Integer;
213 function StringListCompareAnythingAsc(List: TStringList; Index1, Index2: Integer): Integer; 214 function StringListCompareAnythingAsc(List: TStringList; Index1, Index2: Integer): Integer;
214 function StringListCompareAnythingDesc(List: TStringList; Index1, Index2: Integer): Integer; 215 function StringListCompareAnythingDesc(List: TStringList; Index1, Index2: Integer): Integer;
215 function GetColumnDefaultType(var Text: String): TColumnDefaultType; 216 function GetColumnDefaultType(var Text: String): TColumnDefaultType;
216 function GetColumnDefaultClause(DefaultType: TColumnDefaultType; Text: String): String; 217 function GetColumnDefaultClause(DefaultType: TColumnDefaultType; Text: String): String;
217 function GetImageLinkTimeStamp(const FileName: string): TDateTime; 218 function GetImageLinkTimeStamp(const FileName: string): TDateTime;
218 function IsEmpty(Str: String): Boolean; 219 function IsEmpty(Str: String): Boolean;
219 function IsNotEmpty(Str: String): Boolean; 220 function IsNotEmpty(Str: String): Boolean;
220 function MessageDialog(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer; overload; 221 function MessageDialog(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer; overload;
221 function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer; overload; 222 function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer; overload;
222 function ErrorDialog(Msg: string): Integer; overload; 223 function ErrorDialog(Msg: string): Integer; overload;
223 function ErrorDialog(const Title, Msg: string): Integer; overload; 224 function ErrorDialog(const Title, Msg: string): Integer; overload;
224 function GetHTMLCharsetByEncoding(Encoding: TEncoding): String; 225 function GetHTMLCharsetByEncoding(Encoding: TEncoding): String;
225 226
226 var 227 var
227 MainReg: TRegistry; 228 MainReg: TRegistry;
228 RegPath: String = '\Software\' + APPNAME + '\'; 229 RegPath: String = '\Software\' + APPNAME + '\';
229 PortableMode: Boolean = False; 230 PortableMode: Boolean = False;
230 MutexHandle: THandle = 0; 231 MutexHandle: THandle = 0;
231 DecimalSeparatorSystemdefault: Char; 232 DecimalSeparatorSystemdefault: Char;
232 233
233 234
234 implementation 235 implementation
235 236
236 uses main; 237 uses main;
237 238
238 239
239 240
240 function WideHexToBin(text: String): AnsiString; 241 function WideHexToBin(text: String): AnsiString;
241 var 242 var
242 buf: AnsiString; 243 buf: AnsiString;
243 begin 244 begin
244 buf := AnsiString(text); 245 buf := AnsiString(text);
245 SetLength(Result, Length(text) div 2); 246 SetLength(Result, Length(text) div 2);
246 HexToBin(PAnsiChar(buf), @Result[1], Length(Result)); 247 HexToBin(PAnsiChar(buf), @Result[1], Length(Result));
247 end; 248 end;
248 249
249 function BinToWideHex(bin: AnsiString): String; 250 function BinToWideHex(bin: AnsiString): String;
250 var 251 var
251 buf: AnsiString; 252 buf: AnsiString;
252 begin 253 begin
253 SetLength(buf, Length(bin) * 2); 254 SetLength(buf, Length(bin) * 2);
254 BinToHex(@bin[1], PAnsiChar(buf), Length(bin)); 255 BinToHex(@bin[1], PAnsiChar(buf), Length(bin));
255 Result := String(buf); 256 Result := String(buf);
256 end; 257 end;
257 258
258 259
259 {*** 260 {***
260 Convert a TStringList to a string using a separator-string 261 Convert a TStringList to a string using a separator-string
261 262
262 @todo Look at each caller to see if escaping is necessary. 263 @todo Look at each caller to see if escaping is necessary.
263 @param string Separator 264 @param string Separator
264 @param a TStringList Containing strings 265 @param a TStringList Containing strings
265 @return string 266 @return string
266 } 267 }
267 function implodestr(seperator: String; a: TStrings) :String; 268 function implodestr(seperator: String; a: TStrings) :String;
268 var 269 var
269 i : Integer; 270 i : Integer;
270 begin 271 begin
271 Result := ''; 272 Result := '';
272 for i:=0 to a.Count-1 do 273 for i:=0 to a.Count-1 do
273 begin 274 begin
274 Result := Result + a[i]; 275 Result := Result + a[i];
275 if i < a.Count-1 then 276 if i < a.Count-1 then
276 Result := Result + seperator; 277 Result := Result + seperator;
277 end; 278 end;
278 end; 279 end;
279 280
280 281
281 282
282 function Explode(Separator, Text: String): TStringList; 283 function Explode(Separator, Text: String): TStringList;
283 var 284 var
284 i: Integer; 285 i: Integer;
285 Item: String; 286 Item: String;
286 begin 287 begin
287 // Explode a string by separator into a TStringList 288 // Explode a string by separator into a TStringList
288 Result := TStringList.Create; 289 Result := TStringList.Create;
289 while true do begin 290 while true do begin
290 i := Pos(Separator, Text); 291 i := Pos(Separator, Text);
291 if i = 0 then begin 292 if i = 0 then begin
292 // Last or only segment: Add to list if it's the last. Add also if it's not empty and list is empty. 293 // Last or only segment: Add to list if it's the last. Add also if it's not empty and list is empty.
293 // Do not add if list is empty and text is also empty. 294 // Do not add if list is empty and text is also empty.
294 if (Result.Count > 0) or (Text <> '') then 295 if (Result.Count > 0) or (Text <> '') then
295 Result.Add(Text); 296 Result.Add(Text);
296 break; 297 break;
297 end; 298 end;
298 Item := Trim(Copy(Text, 1, i-1)); 299 Item := Trim(Copy(Text, 1, i-1));
299 Result.Add(Item); 300 Result.Add(Item);
300 Delete(Text, 1, i-1+Length(Separator)); 301 Delete(Text, 1, i-1+Length(Separator));
301 end; 302 end;
302 end; 303 end;
303 304
304 305
305 function RemoveComments(SQL: String): String; 306 function RemoveComments(SQL: String): String;
306 begin 307 begin
307 // Remove all kinds of comments from given SQL string 308 // Remove all kinds of comments from given SQL string
308 end; 309 end;
309 310
310 311
311 {*** 312 {***
312 Shorten string to length len and append 3 dots 313 Shorten string to length len and append 3 dots
313 314
314 @param string String to shorten 315 @param string String to shorten
315 @param integer Wished Length of string 316 @param integer Wished Length of string
316 @return string 317 @return string
317 } 318 }
318 function sstr(str: String; len: Integer) : String; 319 function sstr(str: String; len: Integer) : String;
319 begin 320 begin
320 if length(str) > len then 321 if length(str) > len then
321 begin 322 begin
322 str := copy(str, 0, len-1); 323 str := copy(str, 0, len-1);
323 str := str + '…'; 324 str := str + '…';
324 end; 325 end;
325 result := str; 326 result := str;
326 end; 327 end;
327 328
328 329
329 330
330 {*** 331 {***
331 Password-encryption, used to store session-passwords in registry 332 Password-encryption, used to store session-passwords in registry
332 333
333 @param string Text to encrypt 334 @param string Text to encrypt
334 @return string Encrypted Text 335 @return string Encrypted Text
335 } 336 }
336 function encrypt(str: String) : String; 337 function encrypt(str: String) : String;
337 var 338 var
338 i, salt, nr : integer; 339 i, salt, nr : integer;
339 h : String; 340 h : String;
340 begin 341 begin
341 randomize(); 342 randomize();
342 result := ''; 343 result := '';
343 salt := random(9) + 1; 344 salt := random(9) + 1;
344 for i:=1 to length(str) do begin 345 for i:=1 to length(str) do begin
345 nr := ord(str[i])+salt; 346 nr := ord(str[i])+salt;
346 if nr > 255 then 347 if nr > 255 then
347 nr := nr - 255; 348 nr := nr - 255;
348 h := inttohex(nr,0); 349 h := inttohex(nr,0);
349 if length(h) = 1 then 350 if length(h) = 1 then
350 h := '0' + h; 351 h := '0' + h;
351 result := result + h; 352 result := result + h;
352 end; 353 end;
353 result := result + inttostr(salt); 354 result := result + inttostr(salt);
354 end; 355 end;
355 356
356 357
357 358
358 {*** 359 {***
359 Password-decryption, used to restore session-passwords from registry 360 Password-decryption, used to restore session-passwords from registry
360 361
361 @param string Text to decrypt 362 @param string Text to decrypt
362 @return string Decrypted Text 363 @return string Decrypted Text
363 } 364 }
364 function decrypt(str: String) : String; 365 function decrypt(str: String) : String;
365 var 366 var
366 j, salt, nr : integer; 367 j, salt, nr : integer;
367 begin 368 begin
368 result := ''; 369 result := '';
369 if str = '' then exit; 370 if str = '' then exit;
370 j := 1; 371 j := 1;
371 salt := StrToIntDef(str[length(str)],0); 372 salt := StrToIntDef(str[length(str)],0);
372 result := ''; 373 result := '';
373 while j < length(str)-1 do begin 374 while j < length(str)-1 do begin
374 nr := StrToInt('$' + str[j] + str[j+1]) - salt; 375 nr := StrToInt('$' + str[j] + str[j+1]) - salt;
375 if nr < 0 then 376 if nr < 0 then
376 nr := nr + 255; 377 nr := nr + 255;
377 result := result + chr(nr); 378 result := result + chr(nr);
378 inc(j, 2); 379 inc(j, 2);
379 end; 380 end;
380 end; 381 end;
381 382
382 383
383 384
384 {*** 385 {***
385 Convert HTML-characters to their corresponding entities 386 Convert HTML-characters to their corresponding entities
386 387
387 @param string Text used for search+replace 388 @param string Text used for search+replace
388 @return string Text with entities 389 @return string Text with entities
389 } 390 }
390 function htmlentities(str: String) : String; 391 function htmlentities(str: String) : String;
391 begin 392 begin
392 result := StringReplace(str, '&', '&amp;', [rfReplaceAll]); 393 result := StringReplace(str, '&', '&amp;', [rfReplaceAll]);
393 result := StringReplace(result, '<', '&lt;', [rfReplaceAll]); 394 result := StringReplace(result, '<', '&lt;', [rfReplaceAll]);
394 result := StringReplace(result, '>', '&gt;', [rfReplaceAll]); 395 result := StringReplace(result, '>', '&gt;', [rfReplaceAll]);
395 end; 396 end;
396 397
397 398
398 function BestTableName(Data: TDBQuery): String; 399 function BestTableName(Data: TDBQuery): String;
399 begin 400 begin
400 // Get table name from result if possible. Used by GridToXYZ() functions. 401 // Get table name from result if possible. Used by GridToXYZ() functions.
401 try 402 try
402 Result := Data.TableName; 403 Result := Data.TableName;
403 except 404 except
404 Result := 'UnknownTable'; 405 Result := 'UnknownTable';
405 end; 406 end;
406 end; 407 end;
407 408
408 409
409 {*** 410 {***
410 Encode critical characters in URL segments 411 Encode critical characters in URL segments
411 @param string URL to encode 412 @param string URL to encode
412 @return string 413 @return string
413 } 414 }
414 function EncodeURL(const Src: String): String; 415 function EncodeURL(const Src: String): String;
415 var 416 var
416 i: Integer; 417 i: Integer;
417 const 418 const
418 SafeChars = ['A'..'Z','a'..'z','*','@','.','_','-','0'..'9','$','!','''','(',')']; 419 SafeChars = ['A'..'Z','a'..'z','*','@','.','_','-','0'..'9','$','!','''','(',')'];
419 begin 420 begin
420 Result := ''; 421 Result := '';
421 for i:=1 to Length(Src) do begin 422 for i:=1 to Length(Src) do begin
422 if CharInSet(Src[i], SafeChars) then 423 if CharInSet(Src[i], SafeChars) then
423 Result := Result + Src[i] 424 Result := Result + Src[i]
424 else 425 else
425 Result := Result + '%' + IntToHex(Ord(Src[i]), 2); 426 Result := Result + '%' + IntToHex(Ord(Src[i]), 2);
426 end; 427 end;
427 end; 428 end;
428 429
429 430
430 {** 431 {**
431 Write some UTF8 text to a file- or memorystream 432 Write some UTF8 text to a file- or memorystream
432 } 433 }
433 procedure StreamWrite(S: TStream; Text: String = ''); 434 procedure StreamWrite(S: TStream; Text: String = '');
434 var 435 var
435 utf8: AnsiString; 436 utf8: AnsiString;
436 begin 437 begin
437 utf8 := Utf8Encode(Text); 438 utf8 := Utf8Encode(Text);
438 S.Write(utf8[1], Length(utf8)); 439 S.Write(utf8[1], Length(utf8));
439 end; 440 end;
440 441
441 442
442 {*** 443 {***
443 Return filesize of a given file 444 Return filesize of a given file
444 @param string Filename 445 @param string Filename
445 @return int64 Size in bytes 446 @return int64 Size in bytes
446 } 447 }
447 function _GetFileSize(Filename: String): Int64; 448 function _GetFileSize(Filename: String): Int64;
448 var 449 var
449 Attr: _WIN32_FILE_ATTRIBUTE_DATA; 450 Attr: _WIN32_FILE_ATTRIBUTE_DATA;
450 begin 451 begin
451 if FileExists(Filename) then begin 452 if FileExists(Filename) then begin
452 GetFileAttributesEx(PChar(Filename), GetFileExInfoStandard, @Attr); 453 GetFileAttributesEx(PChar(Filename), GetFileExInfoStandard, @Attr);
453 Result := Int64(Attr.nFileSizeHigh) shl 32 + Int64(Attr.nFileSizeLow); 454 Result := Int64(Attr.nFileSizeHigh) shl 32 + Int64(Attr.nFileSizeLow);
454 end else 455 end else
455 Result := -1; 456 Result := -1;
456 end; 457 end;
457 458
458 459
459 {*** 460 {***
460 Convert a string-number to an integer-number 461 Convert a string-number to an integer-number
461 462
462 @param string String-number 463 @param string String-number
463 @return int64 464 @return int64
464 } 465 }
465 function MakeInt( Str: String ) : Int64; 466 function MakeInt( Str: String ) : Int64;
466 begin 467 begin
467 // Result has to be of integer type 468 // Result has to be of integer type
468 Result := Trunc( MakeFloat( Str ) ); 469 Result := Trunc( MakeFloat( Str ) );
469 end; 470 end;
470 471
471 472
472 function CleanupNumber(Str: String): String; 473 function CleanupNumber(Str: String): String;
473 var 474 var
474 i: Integer; 475 i: Integer;
475 HasDecimalSep: Boolean; 476 HasDecimalSep: Boolean;
476 begin 477 begin
477 // Ensure the passed string contains a valid number, which is convertable by StrToFloat afterwards 478 // Ensure the passed string contains a valid number, which is convertable by StrToFloat afterwards
478 // Return it as string again, as there are callers which need to handle unsigned bigint's somehow - 479 // Return it as string again, as there are callers which need to handle unsigned bigint's somehow -
479 // there is no unsigned 64 bit integer type in Delphi. 480 // there is no unsigned 64 bit integer type in Delphi.
480 Result := ''; 481 Result := '';
481 482
482 // Unformatted float coming in? Detect by order of thousand and decimal char 483 // Unformatted float coming in? Detect by order of thousand and decimal char
483 if ((Pos(',', Str) > 0) and (Pos(',', Str) < Pos('.', Str))) 484 if ((Pos(',', Str) > 0) and (Pos(',', Str) < Pos('.', Str)))
484 or ((Pos('.', Str) > 0) and (Pos('.', ReverseString(Str)) <> 4)) 485 or ((Pos('.', Str) > 0) and (Pos('.', ReverseString(Str)) <> 4))
485 then begin 486 then begin
486 Str := StringReplace(Str, '.', '*', [rfReplaceAll]); 487 Str := StringReplace(Str, '.', '*', [rfReplaceAll]);
487 Str := StringReplace(Str, ',', FormatSettings.ThousandSeparator, [rfReplaceAll]); 488 Str := StringReplace(Str, ',', FormatSettings.ThousandSeparator, [rfReplaceAll]);
488 Str := StringReplace(Str, '*', FormatSettings.DecimalSeparator, [rfReplaceAll]); 489 Str := StringReplace(Str, '*', FormatSettings.DecimalSeparator, [rfReplaceAll]);
489 end; 490 end;
490 491
491 HasDecimalSep := False; 492 HasDecimalSep := False;
492 for i:=1 to Length(Str) do begin 493 for i:=1 to Length(Str) do begin
493 if CharInSet(Str[i], ['0'..'9', FormatSettings.DecimalSeparator]) or ((Str[i] = '-') and (Result='')) then 494 if CharInSet(Str[i], ['0'..'9', FormatSettings.DecimalSeparator]) or ((Str[i] = '-') and (Result='')) then
494 begin 495 begin
495 // Avoid confusion and AV in StrToFloat() 496 // Avoid confusion and AV in StrToFloat()
496 if (FormatSettings.ThousandSeparator = FormatSettings.DecimalSeparator) and (Str[i] = FormatSettings.DecimalSeparator) then 497 if (FormatSettings.ThousandSeparator = FormatSettings.DecimalSeparator) and (Str[i] = FormatSettings.DecimalSeparator) then
497 continue; 498 continue;
498 // Ensure only 1 decimalseparator is left 499 // Ensure only 1 decimalseparator is left
499 if (Str[i] = FormatSettings.DecimalSeparator) and HasDecimalSep then 500 if (Str[i] = FormatSettings.DecimalSeparator) and HasDecimalSep then
500 continue; 501 continue;
501 if Str[i] = FormatSettings.DecimalSeparator then 502 if Str[i] = FormatSettings.DecimalSeparator then
502 HasDecimalSep := True; 503 HasDecimalSep := True;
503 Result := Result + Str[i]; 504 Result := Result + Str[i];
504 end; 505 end;
505 end; 506 end;
506 if (Result = '') or (Result = '-') then 507 if (Result = '') or (Result = '-') then
507 Result := '0'; 508 Result := '0';
508 end; 509 end;
509 510
510 511
512 function IsNumeric(Str: String): Boolean;
513 begin
514 Result := IntToStr(MakeInt(Str)) = Str;
515 end;
516
517
511 {*** 518 {***
512 Convert a string-number to an floatingpoint-number 519 Convert a string-number to an floatingpoint-number
513 520
514 @param String text representation of a number 521 @param String text representation of a number
515 @return Extended 522 @return Extended
516 } 523 }
517 function MakeFloat( Str: String ): Extended; 524 function MakeFloat( Str: String ): Extended;
518 var 525 var
519 p_kb, p_mb, p_gb, p_tb, p_pb : Integer; 526 p_kb, p_mb, p_gb, p_tb, p_pb : Integer;
520 begin 527 begin
521 // Convert result to a floating point value to ensure 528 // Convert result to a floating point value to ensure
522 // we don't discard decimal digits for the next step 529 // we don't discard decimal digits for the next step
523 Result := StrToFloat(CleanupNumber(Str)); 530 Result := StrToFloat(CleanupNumber(Str));
524 531
525 // Detect if the string was previously formatted by FormatByteNumber 532 // Detect if the string was previously formatted by FormatByteNumber
526 // and convert it back by multiplying it with its byte unit 533 // and convert it back by multiplying it with its byte unit
527 p_kb := Pos(NAME_KB, Str); 534 p_kb := Pos(NAME_KB, Str);
528 p_mb := Pos(NAME_MB, Str); 535 p_mb := Pos(NAME_MB, Str);
529 p_gb := Pos(NAME_GB, Str); 536 p_gb := Pos(NAME_GB, Str);
530 p_tb := Pos(NAME_TB, Str); 537 p_tb := Pos(NAME_TB, Str);
531 p_pb := Pos(NAME_PB, Str); 538 p_pb := Pos(NAME_PB, Str);
532 539
533 if (p_kb > 0) and (p_kb = Length(Str)-Length(NAME_KB)+1) then 540 if (p_kb > 0) and (p_kb = Length(Str)-Length(NAME_KB)+1) then
534 Result := Result * SIZE_KB 541 Result := Result * SIZE_KB
535 else if (p_mb > 0) and (p_mb = Length(Str)-Length(NAME_MB)+1) then 542 else if (p_mb > 0) and (p_mb = Length(Str)-Length(NAME_MB)+1) then
536 Result := Result * SIZE_MB 543 Result := Result * SIZE_MB
537 else if (p_gb > 0) and (p_gb = Length(Str)-Length(NAME_GB)+1) then 544 else if (p_gb > 0) and (p_gb = Length(Str)-Length(NAME_GB)+1) then
538 Result := Result * SIZE_GB 545 Result := Result * SIZE_GB
539 else if (p_tb > 0) and (p_tb = Length(Str)-Length(NAME_TB)+1) then 546 else if (p_tb > 0) and (p_tb = Length(Str)-Length(NAME_TB)+1) then
540 Result := Result * SIZE_TB 547 Result := Result * SIZE_TB
541 else if (p_pb > 0) and (p_pb = Length(Str)-Length(NAME_PB)+1) then 548 else if (p_pb > 0) and (p_pb = Length(Str)-Length(NAME_PB)+1) then
542 Result := Result * SIZE_PB; 549 Result := Result * SIZE_PB;
543 end; 550 end;
544 551
545 552
546 function esc(Text: String; ProcessJokerChars: Boolean=false; DoQuote: Boolean=True): String; 553 function esc(Text: String; ProcessJokerChars: Boolean=false; DoQuote: Boolean=True): String;
547 begin 554 begin
548 Result := MainForm.ActiveConnection.EscapeString(Text, ProcessJokerChars, DoQuote); 555 Result := MainForm.ActiveConnection.EscapeString(Text, ProcessJokerChars, DoQuote);
549 end; 556 end;
550 557
551 558
552 {*** 559 {***
553 Detect NUL character in a text. 560 Detect NUL character in a text.
554 Useful because fx SynEdit cuts of all text after it encounters a NUL. 561 Useful because fx SynEdit cuts of all text after it encounters a NUL.
555 } 562 }
556 function ScanNulChar(Text: String): boolean; 563 function ScanNulChar(Text: String): boolean;
557 var 564 var
558 i: integer; 565 i: integer;
559 begin 566 begin
560 result := false; 567 result := false;
561 for i:=1 to length(Text) do 568 for i:=1 to length(Text) do
562 begin 569 begin
563 if Text[i] = #0 then 570 if Text[i] = #0 then
564 begin 571 begin
565 result := true; 572 result := true;
566 exit; 573 exit;
567 end; 574 end;
568 end; 575 end;
569 end; 576 end;
570 577
571 578
572 579
573 {*** 580 {***
574 SynEdit removes all newlines and semi-randomly decides a 581 SynEdit removes all newlines and semi-randomly decides a
575 new newline format to use for any text edited. 582 new newline format to use for any text edited.
576 See also: Delphi's incomplete implementation of TTextLineBreakStyle in System.pas 583 See also: Delphi's incomplete implementation of TTextLineBreakStyle in System.pas
577 584
578 @param string Text to test 585 @param string Text to test
579 @return TLineBreaks 586 @return TLineBreaks
580 } 587 }
581 function ScanLineBreaks(Text: String): TLineBreaks; 588 function ScanLineBreaks(Text: String): TLineBreaks;
582 var 589 var
583 i: integer; 590 i: integer;
584 c: Char; 591 c: Char;
585 procedure SetResult(Style: TLineBreaks); 592 procedure SetResult(Style: TLineBreaks);
586 begin 593 begin
587 // Note: Prefer "(foo <> a) and (foo <> b)" over "not (foo in [a, b])" in excessive loops 594 // Note: Prefer "(foo <> a) and (foo <> b)" over "not (foo in [a, b])" in excessive loops
588 // for performance reasons - there is or was a Delphi bug leaving those inline SETs in memory 595 // for performance reasons - there is or was a Delphi bug leaving those inline SETs in memory
589 // after usage. Unfortunately can't remember which bug id it was and if it still exists. 596 // after usage. Unfortunately can't remember which bug id it was and if it still exists.
590 if (Result <> lbsNone) and (Result <> Style) then 597 if (Result <> lbsNone) and (Result <> Style) then
591 Result := lbsMixed 598 Result := lbsMixed
592 else 599 else
593 Result := Style; 600 Result := Style;
594 end; 601 end;
595 begin 602 begin
596 Result := lbsNone; 603 Result := lbsNone;
597 if length(Text) = 0 then exit; 604 if length(Text) = 0 then exit;
598 i := 1; 605 i := 1;
599 repeat 606 repeat
600 c := Text[i]; 607 c := Text[i];
601 if c = #13 then begin 608 if c = #13 then begin
602 if (i < length(Text)) and (Text[i+1] = #10) then begin 609 if (i < length(Text)) and (Text[i+1] = #10) then begin
603 Inc(i); 610 Inc(i);
604 SetResult(lbsWindows); 611 SetResult(lbsWindows);
605 end else 612 end else
606 SetResult(lbsMac); 613 SetResult(lbsMac);
607 end else if c = LB_UNIX then 614 end else if c = LB_UNIX then
608 SetResult(lbsUnix) 615 SetResult(lbsUnix)
609 else if c = LB_WIDE then 616 else if c = LB_WIDE then
610 SetResult(lbsWide); 617 SetResult(lbsWide);
611 i := i + 1; 618 i := i + 1;
612 // No need to do more checks after detecting mixed style 619 // No need to do more checks after detecting mixed style
613 if Result = lbsMixed then 620 if Result = lbsMixed then
614 break; 621 break;
615 until i > length(Text); 622 until i > length(Text);
616 end; 623 end;
617 624
618 625
619 626
620 {*** 627 {***
621 Mangle input text so that SynEdit can load it. 628 Mangle input text so that SynEdit can load it.
622 629
623 @param string Text to test 630 @param string Text to test
624 @return Boolean 631 @return Boolean
625 } 632 }
626 function RemoveNulChars(Text: String): String; 633 function RemoveNulChars(Text: String): String;
627 var 634 var
628 i: integer; 635 i: integer;
629 c: Char; 636 c: Char;
630 begin 637 begin
631 SetLength(Result, Length(Text)); 638 SetLength(Result, Length(Text));
632 if Length(Text) = 0 then Exit; 639 if Length(Text) = 0 then Exit;
633 i := 1; 640 i := 1;
634 repeat 641 repeat
635 c := Text[i]; 642 c := Text[i];
636 if c = #0 then Result[i] := #32 643 if c = #0 then Result[i] := #32
637 else Result[i] := c; 644 else Result[i] := c;
638 i := i + 1; 645 i := i + 1;
639 until i > length(Text); 646 until i > length(Text);
640 end; 647 end;
641 648
642 649
643 650
644 {*** 651 {***
645 Unify CR's and LF's to CRLF 652 Unify CR's and LF's to CRLF
646 653
647 @param string Text to fix 654 @param string Text to fix
648 @return string 655 @return string
649 } 656 }
650 function fixNewlines(txt: String): String; 657 function fixNewlines(txt: String): String;
651 begin 658 begin
652 txt := StringReplace(txt, CRLF, #10, [rfReplaceAll]); 659 txt := StringReplace(txt, CRLF, #10, [rfReplaceAll]);
653 txt := StringReplace(txt, #13, #10, [rfReplaceAll]); 660 txt := StringReplace(txt, #13, #10, [rfReplaceAll]);
654 txt := StringReplace(txt, #10, CRLF, [rfReplaceAll]); 661 txt := StringReplace(txt, #10, CRLF, [rfReplaceAll]);
655 result := txt; 662 result := txt;
656 end; 663 end;
657 664
658 665
659 666
660 {*** 667 {***
661 Get the path of a Windows(r)-shellfolder, specified by an integer or a constant 668 Get the path of a Windows(r)-shellfolder, specified by an integer or a constant
662 669
663 @param integer Number or constant 670 @param integer Number or constant
664 @return string Path 671 @return string Path
665 } 672 }
666 function GetShellFolder(CSIDL: integer): string; 673 function GetShellFolder(CSIDL: integer): string;
667 var 674 var
668 pidl : PItemIdList; 675 pidl : PItemIdList;
669 FolderPath : string; 676 FolderPath : string;
670 SystemFolder : Integer; 677 SystemFolder : Integer;
671 Malloc : IMalloc; 678 Malloc : IMalloc;
672 begin 679 begin
673 Malloc := nil; 680 Malloc := nil;
674 FolderPath := ''; 681 FolderPath := '';
675 SHGetMalloc(Malloc); 682 SHGetMalloc(Malloc);
676 if Malloc = nil then 683 if Malloc = nil then
677 begin 684 begin
678 Result := FolderPath; 685 Result := FolderPath;
679 Exit; 686 Exit;
680 end; 687 end;
681 try 688 try
682 SystemFolder := CSIDL; 689 SystemFolder := CSIDL;
683 if SUCCEEDED(SHGetSpecialFolderLocation(0, SystemFolder, pidl)) then 690 if SUCCEEDED(SHGetSpecialFolderLocation(0, SystemFolder, pidl)) then
684 begin 691 begin
685 SetLength(FolderPath, max_path); 692 SetLength(FolderPath, max_path);
686 if SHGetPathFromIDList(pidl, PChar(FolderPath)) then 693 if SHGetPathFromIDList(pidl, PChar(FolderPath)) then
687 begin 694 begin
688 SetLength(FolderPath, length(PChar(FolderPath))); 695 SetLength(FolderPath, length(PChar(FolderPath)));
689 end; 696 end;
690 end; 697 end;
691 Result := FolderPath; 698 Result := FolderPath;
692 finally 699 finally
693 Malloc.Free(pidl); 700 Malloc.Free(pidl);
694 end; 701 end;
695 end; 702 end;
696 703
697 704
698 705
699 {*** 706 {***
700 Remove special characters from a filename 707 Remove special characters from a filename
701 708
702 @param string Filename 709 @param string Filename
703 @return string 710 @return string
704 } 711 }
705 function goodfilename( str: String ): String; 712 function goodfilename( str: String ): String;
706 var 713 var
707 c : Char; 714 c : Char;
708 begin 715 begin
709 result := str; 716 result := str;
710 for c in ['\', '/', ':', '*', '?', '"', '<', '>', '|'] do 717 for c in ['\', '/', ':', '*', '?', '"', '<', '>', '|'] do
711 result := StringReplace( result, c, '_', [rfReplaceAll] ); 718 result := StringReplace( result, c, '_', [rfReplaceAll] );
712 end; 719 end;
713 720
714 721
715 722
716 {** 723 {**
717 Unformat a formatted integer or float. Used for CSV export and composing WHERE clauses for grid editing. 724 Unformat a formatted integer or float. Used for CSV export and composing WHERE clauses for grid editing.
718 } 725 }
719 function UnformatNumber(Val: String): String; 726 function UnformatNumber(Val: String): String;
720 var 727 var
721 i: Integer; 728 i: Integer;
722 HasDecim: Boolean; 729 HasDecim: Boolean;
723 c: Char; 730 c: Char;
724 const 731 const
725 Numbers = ['0'..'9']; 732 Numbers = ['0'..'9'];
726 begin 733 begin
727 Result := ''; 734 Result := '';
728 HasDecim := False; 735 HasDecim := False;
729 for i:=1 to Length(Val) do begin 736 for i:=1 to Length(Val) do begin
730 c := Val[i]; 737 c := Val[i];
731 if CharInSet(c, Numbers) or ((c = '-') and (i = 1)) then 738 if CharInSet(c, Numbers) or ((c = '-') and (i = 1)) then
732 Result := Result + c 739 Result := Result + c
733 else if (c = FormatSettings.DecimalSeparator) and (not HasDecim) then begin 740 else if (c = FormatSettings.DecimalSeparator) and (not HasDecim) then begin
734 Result := Result + '.'; 741 Result := Result + '.';
735 HasDecim := True; 742 HasDecim := True;
736 end else if c <> FormatSettings.ThousandSeparator then 743 end else if c <> FormatSettings.ThousandSeparator then
737 break; 744 break;
738 end; 745 end;
739 if Result = '' then 746 if Result = '' then
740 Result := '0'; 747 Result := '0';
741 end; 748 end;
742 749
743 750
744 {*** 751 {***
745 Return a formatted integer or float from a string 752 Return a formatted integer or float from a string
746 @param string Text containing a number 753 @param string Text containing a number
747 @return string 754 @return string
748 } 755 }
749 function FormatNumber(str: String; Thousands: Boolean=True): String; Overload; 756 function FormatNumber(str: String; Thousands: Boolean=True): String; Overload;
750 var 757 var
751 i, p, Left: Integer; 758 i, p, Left: Integer;
752 begin 759 begin
753 Result := StringReplace(str, '.', FormatSettings.DecimalSeparator, [rfReplaceAll]); 760 Result := StringReplace(str, '.', FormatSettings.DecimalSeparator, [rfReplaceAll]);
754 if Thousands then begin 761 if Thousands then begin
755 // Do not add thousand separators to zerofilled numbers 762 // Do not add thousand separators to zerofilled numbers
756 if ((Length(Result) >= 1) and (Result[1] = '0')) 763 if ((Length(Result) >= 1) and (Result[1] = '0'))
757 or ((Length(Result) >= 2) and (Result[1] = '-') and (Result[2] = '0')) 764 or ((Length(Result) >= 2) and (Result[1] = '-') and (Result[2] = '0'))
758 then 765 then
759 Exit; 766 Exit;
760 p := Pos(FormatSettings.DecimalSeparator, Result); 767 p := Pos(FormatSettings.DecimalSeparator, Result);
761 if p = 0 then p := Length(Result)+1; 768 if p = 0 then p := Length(Result)+1;
762 Left := 2; 769 Left := 2;
763 if (Length(Result) >= 1) and (Result[1] = '-') then 770 if (Length(Result) >= 1) and (Result[1] = '-') then
764 Left := 3; 771 Left := 3;
765 if p > 0 then for i:=p-1 downto Left do begin 772 if p > 0 then for i:=p-1 downto Left do begin
766 if (p-i) mod 3 = 0 then 773 if (p-i) mod 3 = 0 then
767 Insert(FormatSettings.ThousandSeparator, Result, i); 774 Insert(FormatSettings.ThousandSeparator, Result, i);
768 end; 775 end;
769 end; 776 end;
770 end; 777 end;
771 778
772 779
773 780
774 {*** 781 {***
775 Return a formatted number from an integer 782 Return a formatted number from an integer
776 783
777 @param int64 Number to format 784 @param int64 Number to format
778 @return string 785 @return string
779 } 786 }
780 function FormatNumber(int: Int64; Thousands: Boolean=True): String; Overload; 787 function FormatNumber(int: Int64; Thousands: Boolean=True): String; Overload;
781 begin 788 begin
782 result := FormatNumber(IntToStr(int), Thousands); 789 result := FormatNumber(IntToStr(int), Thousands);
783 end; 790 end;
784 791
785 792
786 793
787 {*** 794 {***
788 Return a formatted number from a float 795 Return a formatted number from a float
789 This function is called by two overloaded functions 796 This function is called by two overloaded functions
790 797
791 @param double Number to format 798 @param double Number to format
792 @param integer Number of decimals 799 @param integer Number of decimals
793 @return string 800 @return string
794 } 801 }
795 function FormatNumber(flt: Double; decimals: Integer = 0; Thousands: Boolean=True): String; Overload; 802 function FormatNumber(flt: Double; decimals: Integer = 0; Thousands: Boolean=True): String; Overload;
796 begin 803 begin
797 Result := Format('%10.'+IntToStr(decimals)+'f', [flt]); 804 Result := Format('%10.'+IntToStr(decimals)+'f', [flt]);
798 Result := Trim(Result); 805 Result := Trim(Result);
799 Result := FormatNumber(Result, Thousands); 806 Result := FormatNumber(Result, Thousands);
800 end; 807 end;
801 808
802 809
803 810
804 {*** 811 {***
805 Set global variables containing the standard local format for date and time 812 Set global variables containing the standard local format for date and time
806 values. Standard means the MySQL-standard format, which is YYYY-MM-DD HH:MM:SS 813 values. Standard means the MySQL-standard format, which is YYYY-MM-DD HH:MM:SS
807 814
808 @note Be aware that Delphi internally converts the slashes in ShortDateFormat 815 @note Be aware that Delphi internally converts the slashes in ShortDateFormat
809 to the DateSeparator 816 to the DateSeparator
810 } 817 }
811 procedure setLocales; 818 procedure setLocales;
812 begin 819 begin
813 FormatSettings.DateSeparator := '-'; 820 FormatSettings.DateSeparator := '-';
814 FormatSettings.TimeSeparator := ':'; 821 FormatSettings.TimeSeparator := ':';
815 FormatSettings.ShortDateFormat := 'yyyy/mm/dd'; 822 FormatSettings.ShortDateFormat := 'yyyy/mm/dd';
816 FormatSettings.LongTimeFormat := 'hh:nn:ss'; 823 FormatSettings.LongTimeFormat := 'hh:nn:ss';
817 if DecimalSeparatorSystemdefault = '' then 824 if DecimalSeparatorSystemdefault = '' then
818 DecimalSeparatorSystemdefault := FormatSettings.DecimalSeparator; 825 DecimalSeparatorSystemdefault := FormatSettings.DecimalSeparator;
819 FormatSettings.DecimalSeparator := DecimalSeparatorSystemdefault; 826 FormatSettings.DecimalSeparator := DecimalSeparatorSystemdefault;
820 end; 827 end;
821 828
822 829
823 830
824 {*** 831 {***
825 Open URL or execute system command 832 Open URL or execute system command
826 833
827 @param string Command or URL to execute 834 @param string Command or URL to execute
828 @param string Working directory, only usefull is first param is a system command 835 @param string Working directory, only usefull is first param is a system command
829 } 836 }
830 procedure ShellExec(cmd: String; path: String=''; params: String=''); 837 procedure ShellExec(cmd: String; path: String=''; params: String='');
831 begin 838 begin
832 ShellExecute(0, 'open', PChar(cmd), PChar(params), PChar(path), SW_SHOWNORMAL); 839 ShellExecute(0, 'open', PChar(cmd), PChar(params), PChar(path), SW_SHOWNORMAL);
833 end; 840 end;
834 841
835 842
836 843
837 {*** 844 {***
838 Returns first word of a given text 845 Returns first word of a given text
839 @param string Given text 846 @param string Given text
840 @return string First word-boundary 847 @return string First word-boundary
841 } 848 }
842 function getFirstWord( text: String ): String; 849 function getFirstWord( text: String ): String;
843 var 850 var
844 i : Integer; 851 i : Integer;
845 wordChars, wordCharsFirst : TSysCharSet; 852 wordChars, wordCharsFirst : TSysCharSet;
846 begin 853 begin
847 result := ''; 854 result := '';
848 text := trim( text ); 855 text := trim( text );
849 // First char in word must not be numerical. Fixes queries like 856 // First char in word must not be numerical. Fixes queries like
850 // /*!40000 SHOW ENGINES */ to be recognized as "result"-queries 857 // /*!40000 SHOW ENGINES */ to be recognized as "result"-queries
851 // while not breaking getFirstWord in situations where the second 858 // while not breaking getFirstWord in situations where the second
852 // or later char can be a number (fx the collation in createdatabase). 859 // or later char can be a number (fx the collation in createdatabase).
853 wordChars := ['a'..'z', 'A'..'Z', '0'..'9', '_', '-']; 860 wordChars := ['a'..'z', 'A'..'Z', '0'..'9', '_', '-'];
854 wordCharsFirst := wordChars - ['0'..'9']; 861 wordCharsFirst := wordChars - ['0'..'9'];
855 i := 1; 862 i := 1;
856 863
857 // Find beginning of the first word, ignoring non-alphanumeric chars at the very start 864 // Find beginning of the first word, ignoring non-alphanumeric chars at the very start
858 // @see bug #1692828 865 // @see bug #1692828
859 while i < Length(text) do 866 while i < Length(text) do
860 begin 867 begin
861 if CharInSet(text[i], wordCharsFirst) then 868 if CharInSet(text[i], wordCharsFirst) then
862 begin 869 begin
863 // Found beginning of word! 870 // Found beginning of word!
864 break; 871 break;
865 end; 872 end;
866 if i = Length(text)-1 then 873 if i = Length(text)-1 then
867 begin 874 begin
868 // Give up in the very last loop, reset counter 875 // Give up in the very last loop, reset counter
869 // and break. We can't find the start of a word 876 // and break. We can't find the start of a word
870 i := 1; 877 i := 1;
871 break; 878 break;
872 end; 879 end;
873 inc(i); 880 inc(i);
874 end; 881 end;
875 882
876 // Add chars as long as they're alpha-numeric 883 // Add chars as long as they're alpha-numeric
877 while i <= Length(text) do 884 while i <= Length(text) do
878 begin 885 begin
879 if ((result = '') and CharInSet(text[i], wordCharsFirst)) or CharInSet(text[i], wordChars) then 886 if ((result = '') and CharInSet(text[i], wordCharsFirst)) or CharInSet(text[i], wordChars) then
880 begin 887 begin
881 result := result + text[i]; 888 result := result + text[i];
882 end 889 end
883 else 890 else
884 begin 891 begin
885 // Stop here because we found a non-alphanumeric char. 892 // Stop here because we found a non-alphanumeric char.
886 // This applies to all different whitespaces, brackets, commas etc. 893 // This applies to all different whitespaces, brackets, commas etc.
887 break; 894 break;
888 end; 895 end;
889 inc(i); 896 inc(i);
890 end; 897 end;
891 end; 898 end;
892 899
893 900
894 {** 901 {**
895 Format a filesize to automatically use the best fitting expression 902 Format a filesize to automatically use the best fitting expression
896 16 100 000 Bytes -> 16,1 MB 903 16 100 000 Bytes -> 16,1 MB
897 4 500 Bytes -> 4,5 KB 904 4 500 Bytes -> 4,5 KB
898 @param Int64 Number of Bytes 905 @param Int64 Number of Bytes
899 @param Byte Decimals to display when bytes is bigger than 1M 906 @param Byte Decimals to display when bytes is bigger than 1M
900 } 907 }
901 function FormatByteNumber( Bytes: Int64; Decimals: Byte = 1 ): String; Overload; 908 function FormatByteNumber( Bytes: Int64; Decimals: Byte = 1 ): String; Overload;
902 begin 909 begin
903 if Bytes >= SIZE_PB then 910 if Bytes >= SIZE_PB then
904 Result := FormatNumber( Bytes / SIZE_PB, Decimals ) + NAME_PB 911 Result := FormatNumber( Bytes / SIZE_PB, Decimals ) + NAME_PB
905 else if Bytes >= SIZE_TB then 912 else if Bytes >= SIZE_TB then
906 Result := FormatNumber( Bytes / SIZE_TB, Decimals ) + NAME_TB 913 Result := FormatNumber( Bytes / SIZE_TB, Decimals ) + NAME_TB
907 else if Bytes >= SIZE_GB then 914 else if Bytes >= SIZE_GB then
908 Result := FormatNumber( Bytes / SIZE_GB, Decimals ) + NAME_GB 915 Result := FormatNumber( Bytes / SIZE_GB, Decimals ) + NAME_GB
909 else if Bytes >= SIZE_MB then 916 else if Bytes >= SIZE_MB then
910 Result := FormatNumber( Bytes / SIZE_MB, Decimals ) + NAME_MB 917 Result := FormatNumber( Bytes / SIZE_MB, Decimals ) + NAME_MB
911 else if Bytes >= SIZE_KB then 918 else if Bytes >= SIZE_KB then
912 Result := FormatNumber( Bytes / SIZE_KB, Decimals ) + NAME_KB 919 Result := FormatNumber( Bytes / SIZE_KB, Decimals ) + NAME_KB
913 else 920 else
914 Result := FormatNumber( Bytes ) + NAME_BYTES 921 Result := FormatNumber( Bytes ) + NAME_BYTES
915 end; 922 end;
916 923
917 924
918 {** 925 {**
919 An overloaded function of the previous one which can 926 An overloaded function of the previous one which can
920 take a string as input 927 take a string as input
921 } 928 }
922 function FormatByteNumber( Bytes: String; Decimals: Byte = 1 ): String; Overload; 929 function FormatByteNumber( Bytes: String; Decimals: Byte = 1 ): String; Overload;
923 begin 930 begin
924 Result := FormatByteNumber( MakeInt(Bytes), Decimals ); 931 Result := FormatByteNumber( MakeInt(Bytes), Decimals );
925 end; 932 end;
926 933
927 934
928 {** 935 {**
929 Format a number of seconds to a human readable time format 936 Format a number of seconds to a human readable time format
930 @param Cardinal Number of seconds 937 @param Cardinal Number of seconds
931 @result String 12:34:56 938 @result String 12:34:56
932 } 939 }
933 function FormatTimeNumber(Seconds: Cardinal; DisplaySeconds: Boolean): String; 940 function FormatTimeNumber(Seconds: Cardinal; DisplaySeconds: Boolean): String;
934 var 941 var
935 d, h, m, s : Integer; 942 d, h, m, s : Integer;
936 begin 943 begin
937 s := Seconds; 944 s := Seconds;
938 d := s div (60*60*24); 945 d := s div (60*60*24);
939 s := s mod (60*60*24); 946 s := s mod (60*60*24);
940 h := s div (60*60); 947 h := s div (60*60);
941 s := s mod (60*60); 948 s := s mod (60*60);
942 m := s div 60; 949 m := s div 60;
943 s := s mod 60; 950 s := s mod 60;
944 if d > 0 then begin 951 if d > 0 then begin
945 if DisplaySeconds then 952 if DisplaySeconds then
946 Result := Format('%d days, %.2d:%.2d:%.2d', [d, h, m, s]) 953 Result := Format('%d days, %.2d:%.2d:%.2d', [d, h, m, s])
947 else 954 else
948 Result := Format('%d days, %.2d:%.2d h', [d, h, m]); 955 Result := Format('%d days, %.2d:%.2d h', [d, h, m]);
949 end else begin 956 end else begin
950 if DisplaySeconds then 957 if DisplaySeconds then
951 Result := Format('%.2d:%.2d:%.2d', [h, m, s]) 958 Result := Format('%.2d:%.2d:%.2d', [h, m, s])
952 else 959 else
953 Result := Format('%.2d:%.2d h', [h, m]) 960 Result := Format('%.2d:%.2d h', [h, m])
954 end; 961 end;
955 end; 962 end;
956 963
957 964
958 function GetTempDir: String; 965 function GetTempDir: String;
959 var 966 var
960 TempPath: array[0..MAX_PATH] of Char; 967 TempPath: array[0..MAX_PATH] of Char;
961 begin 968 begin
962 GetTempPath(MAX_PATH, PChar(@TempPath)); 969 GetTempPath(MAX_PATH, PChar(@TempPath));
963 Result := StrPas(TempPath); 970 Result := StrPas(TempPath);
964 end; 971 end;
965 972
966 973
967 { 974 {
968 Code taken from SizeGripHWND.pas: 975 Code taken from SizeGripHWND.pas:
969 Copyright (C) 2005, 2006 Volker Siebert <flocke@vssd.de> 976 Copyright (C) 2005, 2006 Volker Siebert <flocke@vssd.de>
970 Alle Rechte vorbehalten. 977 Alle Rechte vorbehalten.
971 978
972 Permission is hereby granted, free of charge, to any person obtaining a 979 Permission is hereby granted, free of charge, to any person obtaining a
973 copy of this software and associated documentation files (the "Software"), 980 copy of this software and associated documentation files (the "Software"),
974 to deal in the Software without restriction, including without limitation 981 to deal in the Software without restriction, including without limitation
975 the rights to use, copy, modify, merge, publish, distribute, sublicense, 982 the rights to use, copy, modify, merge, publish, distribute, sublicense,
976 and/or sell copies of the Software, and to permit persons to whom the 983 and/or sell copies of the Software, and to permit persons to whom the
977 Software is furnished to do so, subject to the following conditions: 984 Software is furnished to do so, subject to the following conditions:
978 985
979 The above copyright notice and this permission notice shall be included in 986 The above copyright notice and this permission notice shall be included in
980 all copies or substantial portions of the Software. 987 all copies or substantial portions of the Software.
981 } 988 }
982 function SizeGripWndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; 989 function SizeGripWndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
983 var 990 var
984 Info: PGripInfo; 991 Info: PGripInfo;
985 dc: HDC; 992 dc: HDC;
986 pt: TPoint; 993 pt: TPoint;
987 994
988 // Invalidate the current grip rectangle 995 // Invalidate the current grip rectangle
989 procedure InvalidateGrip; 996 procedure InvalidateGrip;
990 begin 997 begin
991 with Info^ do 998 with Info^ do
992 if (GripRect.Right > GripRect.Left) and 999 if (GripRect.Right > GripRect.Left) and
993 (GripRect.Bottom > GripRect.Top) then 1000 (GripRect.Bottom > GripRect.Top) then
994 InvalidateRect(hWnd, @GripRect, true); 1001 InvalidateRect(hWnd, @GripRect, true);
995 end; 1002 end;
996 1003
997 // Update (and invalidate) the current grip rectangle 1004 // Update (and invalidate) the current grip rectangle
998 procedure UpdateGrip; 1005 procedure UpdateGrip;
999 begin 1006 begin
1000 with Info^ do 1007 with Info^ do
1001 begin 1008 begin
1002 GetClientRect(hWnd, GripRect); 1009 GetClientRect(hWnd, GripRect);
1003 GripRect.Left := GripRect.Right - GetSystemMetrics(SM_CXHSCROLL); 1010 GripRect.Left := GripRect.Right - GetSystemMetrics(SM_CXHSCROLL);
1004 GripRect.Top := GripRect.Bottom - GetSystemMetrics(SM_CYVSCROLL); 1011 GripRect.Top := GripRect.Bottom - GetSystemMetrics(SM_CYVSCROLL);
1005 end; 1012 end;
1006 1013
1007 InvalidateGrip; 1014 InvalidateGrip;
1008 end; 1015 end;
1009 1016
1010 function CallOld: LRESULT; 1017 function CallOld: LRESULT;
1011 begin 1018 begin
1012 Result := CallWindowProc(@Info^.OldWndProc, hWnd, Msg, wParam, lParam); 1019 Result := CallWindowProc(@Info^.OldWndProc, hWnd, Msg, wParam, lParam);
1013 end; 1020 end;
1014 1021
1015 begin 1022 begin
1016 Info := PGripInfo(GetProp(hWnd, SizeGripProp)); 1023 Info := PGripInfo(GetProp(hWnd, SizeGripProp));
1017 if Info = nil then 1024 if Info = nil then
1018 Result := DefWindowProc(hWnd, Msg, wParam, lParam) 1025 Result := DefWindowProc(hWnd, Msg, wParam, lParam)
1019 else if not Info^.Enabled then 1026 else if not Info^.Enabled then
1020 Result := CallOld 1027 Result := CallOld
1021 else 1028 else
1022 begin 1029 begin
1023 case Msg of 1030 case Msg of
1024 WM_NCDESTROY: begin 1031 WM_NCDESTROY: begin
1025 Result := CallOld; 1032 Result := CallOld;
1026 1033
1027 SetWindowLong(hWnd, GWL_WNDPROC, LongInt(@Info^.OldWndProc)); 1034 SetWindowLong(hWnd, GWL_WNDPROC, LongInt(@Info^.OldWndProc));
1028 RemoveProp(hWnd, SizeGripProp); 1035 RemoveProp(hWnd, SizeGripProp);
1029 Dispose(Info); 1036 Dispose(Info);
1030 end; 1037 end;
1031 1038
1032 WM_PAINT: begin 1039 WM_PAINT: begin
1033 Result := CallOld; 1040 Result := CallOld;
1034 if wParam = 0 then 1041 if wParam = 0 then
1035 begin 1042 begin
1036 dc := GetDC(hWnd); 1043 dc := GetDC(hWnd);
1037 DrawFrameControl(dc, Info^.GripRect, DFC_SCROLL, DFCS_SCROLLSIZEGRIP); 1044 DrawFrameControl(dc, Info^.GripRect, DFC_SCROLL, DFCS_SCROLLSIZEGRIP);
1038 ReleaseDC(hWnd, dc); 1045 ReleaseDC(hWnd, dc);
1039 end; 1046 end;
1040 end; 1047 end;
1041 1048
1042 WM_NCHITTEST: begin 1049 WM_NCHITTEST: begin
1043 pt.x := TSmallPoint(lParam).x; 1050 pt.x := TSmallPoint(lParam).x;
1044 pt.y := TSmallPoint(lParam).y; 1051 pt.y := TSmallPoint(lParam).y;
1045 ScreenToClient(hWnd, pt); 1052 ScreenToClient(hWnd, pt);
1046 if PtInRect(Info^.GripRect, pt) then 1053 if PtInRect(Info^.GripRect, pt) then
1047 Result := HTBOTTOMRIGHT 1054 Result := HTBOTTOMRIGHT
1048 else 1055 else
1049 Result := CallOld; 1056 Result := CallOld;
1050 end; 1057 end;
1051 1058
1052 WM_SIZE: begin 1059 WM_SIZE: begin
1053 InvalidateGrip; 1060 InvalidateGrip;
1054 Result := CallOld; 1061 Result := CallOld;
1055 UpdateGrip; 1062 UpdateGrip;
1056 end; 1063 end;
1057 1064
1058 else 1065 else
1059 Result := CallOld; 1066 Result := CallOld;
1060 end; 1067 end;
1061 end; 1068 end;
1062 end; 1069 end;
1063 1070
1064 { Note that SetWindowSizeGrip(..., false) does not really remove the hook - 1071 { Note that SetWindowSizeGrip(..., false) does not really remove the hook -
1065 it just sets "Enabled" to false. The hook plus all data is removed when 1072 it just sets "Enabled" to false. The hook plus all data is removed when
1066 the window is destroyed. 1073 the window is destroyed.
1067 } 1074 }
1068 procedure SetWindowSizeGrip(hWnd: HWND; Enable: boolean); 1075 procedure SetWindowSizeGrip(hWnd: HWND; Enable: boolean);
1069 var 1076 var
1070 Info: PGripInfo; 1077 Info: PGripInfo;
1071 begin 1078 begin
1072 Info := PGripInfo(GetProp(hWnd, SizeGripProp)); 1079 Info := PGripInfo(GetProp(hWnd, SizeGripProp));
1073 if (Info = nil) and Enable then 1080 if (Info = nil) and Enable then
1074 begin 1081 begin
1075 New(Info); 1082 New(Info);
1076 FillChar(Info^, SizeOf(TGripInfo), 0); 1083 FillChar(Info^, SizeOf(TGripInfo), 0);
1077 1084
1078 with Info^ do 1085 with Info^ do
1079 begin 1086 begin
1080 Info^.OldWndProc := TWndProc(Pointer(GetWindowLong(hWnd, GWL_WNDPROC))); 1087 Info^.OldWndProc := TWndProc(Pointer(GetWindowLong(hWnd, GWL_WNDPROC)));
1081 1088
1082 GetClientRect(hWnd, GripRect); 1089 GetClientRect(hWnd, GripRect);
1083 GripRect.Left := GripRect.Right - GetSystemMetrics(SM_CXHSCROLL); 1090 GripRect.Left := GripRect.Right - GetSystemMetrics(SM_CXHSCROLL);
1084 GripRect.Top := GripRect.Bottom - GetSystemMetrics(SM_CYVSCROLL); 1091 GripRect.Top := GripRect.Bottom - GetSystemMetrics(SM_CYVSCROLL);
1085 end; 1092 end;
1086 1093
1087 SetProp(hWnd, SizeGripProp, Cardinal(Info)); 1094 SetProp(hWnd, SizeGripProp, Cardinal(Info));
1088 SetWindowLong(hWnd, GWL_WNDPROC, LongInt(@SizeGripWndProc)); 1095 SetWindowLong(hWnd, GWL_WNDPROC, LongInt(@SizeGripWndProc));
1089 end; 1096 end;
1090 1097
1091 if (Info <> nil) then 1098 if (Info <> nil) then
1092 if Enable <> Info^.Enabled then 1099 if Enable <> Info^.Enabled then
1093 with Info^ do 1100 with Info^ do
1094 begin 1101 begin
1095 Enabled := Enable; 1102 Enabled := Enable;
1096 if (GripRect.Right > GripRect.Left) and 1103 if (GripRect.Right > GripRect.Left) and
1097 (GripRect.Bottom > GripRect.Top) then 1104 (GripRect.Bottom > GripRect.Top) then
1098 InvalidateRect(hWnd, @GripRect, true); 1105 InvalidateRect(hWnd, @GripRect, true);
1099 end; 1106 end;
1100 end; 1107 end;
1101 1108
1102 1109
1103 {** 1110 {**
1104 Save a textfile with unicode 1111 Save a textfile with unicode
1105 } 1112 }
1106 procedure SaveUnicodeFile(Filename: String; Text: String); 1113 procedure SaveUnicodeFile(Filename: String; Text: String);
1107 var 1114 var
1108 f: TFileStream; 1115 f: TFileStream;
1109 begin 1116 begin
1110 f := TFileStream.Create(Filename, fmCreate or fmOpenWrite); 1117 f := TFileStream.Create(Filename, fmCreate or fmOpenWrite);
1111 StreamWrite(f, Text); 1118 StreamWrite(f, Text);
1112 f.Free; 1119 f.Free;
1113 end; 1120 end;
1114 1121
1115 1122
1116 {** 1123 {**
1117 Open a textfile unicode safe and return a stream + its charset 1124 Open a textfile unicode safe and return a stream + its charset
1118 } 1125 }
1119 procedure OpenTextFile(const Filename: String; out Stream: TFileStream; var Encoding: TEncoding); 1126 procedure OpenTextFile(const Filename: String; out Stream: TFileStream; var Encoding: TEncoding);
1120 var 1127 var
1121 Header: TBytes; 1128 Header: TBytes;
1122 BomLen: Integer; 1129 BomLen: Integer;
1123 begin 1130 begin
1124 Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone); 1131 Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone);
1125 if Encoding = nil then 1132 if Encoding = nil then
1126 Encoding := DetectEncoding(Stream); 1133 Encoding := DetectEncoding(Stream);
1127 // If the file contains a BOM, advance the stream's position 1134 // If the file contains a BOM, advance the stream's position
1128 BomLen := 0; 1135 BomLen := 0;
1129 if Length(Encoding.GetPreamble) > 0 then begin 1136 if Length(Encoding.GetPreamble) > 0 then begin
1130 SetLength(Header, Length(Encoding.GetPreamble)); 1137 SetLength(Header, Length(Encoding.GetPreamble));
1131 Stream.ReadBuffer(Pointer(Header)^, Length(Header)); 1138 Stream.ReadBuffer(Pointer(Header)^, Length(Header));
1132 if CompareMem(Header, Encoding.GetPreamble, SizeOf(Header)) then 1139 if CompareMem(Header, Encoding.GetPreamble, SizeOf(Header)) then
1133 BomLen := Length(Encoding.GetPreamble); 1140 BomLen := Length(Encoding.GetPreamble);
1134 end; 1141 end;
1135 Stream.Position := BomLen; 1142 Stream.Position := BomLen;
1136 end; 1143 end;
1137 1144
1138 1145
1139 {** 1146 {**
1140 Detect stream's content encoding by examing first 100k bytes (MaxBufferSize). Result can be: 1147 Detect stream's content encoding by examing first 100k bytes (MaxBufferSize). Result can be:
1141 UTF-16 BE with BOM 1148 UTF-16 BE with BOM
1142 UTF-16 LE with BOM 1149 UTF-16 LE with BOM
1143 UTF-8 with or without BOM 1150 UTF-8 with or without BOM
1144 ANSI 1151 ANSI
1145 Aimed to work better than WideStrUtils.IsUTF8String() which didn't work in any test case here. 1152 Aimed to work better than WideStrUtils.IsUTF8String() which didn't work in any test case here.
1146 @see http://en.wikipedia.org/wiki/Byte_Order_Mark 1153 @see http://en.wikipedia.org/wiki/Byte_Order_Mark
1147 } 1154 }
1148 function DetectEncoding(Stream: TStream): TEncoding; 1155 function DetectEncoding(Stream: TStream): TEncoding;
1149 var 1156 var
1150 ByteOrderMark: Char; 1157 ByteOrderMark: Char;
1151 BytesRead: Integer; 1158 BytesRead: Integer;
1152 Utf8Test: array[0..2] of AnsiChar; 1159 Utf8Test: array[0..2] of AnsiChar;
1153 Buffer: array of Byte; 1160 Buffer: array of Byte;
1154 BufferSize, i, FoundUTF8Strings: Integer; 1161 BufferSize, i, FoundUTF8Strings: Integer;
1155 const 1162 const
1156 UNICODE_BOM = Char($FEFF); 1163 UNICODE_BOM = Char($FEFF);
1157 UNICODE_BOM_SWAPPED = Char($FFFE); 1164 UNICODE_BOM_SWAPPED = Char($FFFE);
1158 UTF8_BOM = AnsiString(#$EF#$BB#$BF); 1165 UTF8_BOM = AnsiString(#$EF#$BB#$BF);
1159 MinimumCountOfUTF8Strings = 1; 1166 MinimumCountOfUTF8Strings = 1;
1160 MaxBufferSize = 100000; 1167 MaxBufferSize = 100000;
1161 1168
1162 // 3 trailing bytes are the maximum in valid UTF-8 streams, 1169 // 3 trailing bytes are the maximum in valid UTF-8 streams,
1163 // so a count of 4 trailing bytes is enough to detect invalid UTF-8 streams 1170 // so a count of 4 trailing bytes is enough to detect invalid UTF-8 streams
1164 function CountOfTrailingBytes: Integer; 1171 function CountOfTrailingBytes: Integer;
1165 begin 1172 begin
1166 Result := 0; 1173 Result := 0;
1167 inc(i); 1174 inc(i);
1168 while (i < BufferSize) and (Result < 4) do begin 1175 while (i < BufferSize) and (Result < 4) do begin
1169 if Buffer[i] in [$80..$BF] then 1176 if Buffer[i] in [$80..$BF] then
1170 inc(Result) 1177 inc(Result)
1171 else 1178 else
1172 Break; 1179 Break;
1173 inc(i); 1180 inc(i);
1174 end; 1181 end;
1175 end; 1182 end;
1176 1183
1177 begin 1184 begin
1178 // Byte Order Mark 1185 // Byte Order Mark
1179 ByteOrderMark := #0; 1186 ByteOrderMark := #0;
1180 if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin 1187 if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin
1181 BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark)); 1188 BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark));
1182 if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin 1189 if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin
1183 ByteOrderMark := #0; 1190 ByteOrderMark := #0;
1184 Stream.Seek(-BytesRead, soFromCurrent); 1191 Stream.Seek(-BytesRead, soFromCurrent);
1185 if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin 1192 if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin
1186 BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar)); 1193 BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar));
1187 if Utf8Test <> UTF8_BOM then 1194 if Utf8Test <> UTF8_BOM then
1188 Stream.Seek(-BytesRead, soFromCurrent); 1195 Stream.Seek(-BytesRead, soFromCurrent);
1189 end; 1196 end;
1190 end; 1197 end;
1191 end; 1198 end;
1192 // Test Byte Order Mark 1199 // Test Byte Order Mark
1193 if ByteOrderMark = UNICODE_BOM then 1200 if ByteOrderMark = UNICODE_BOM then
1194 Result := TEncoding.Unicode 1201 Result := TEncoding.Unicode
1195 else if ByteOrderMark = UNICODE_BOM_SWAPPED then 1202 else if ByteOrderMark = UNICODE_BOM_SWAPPED then
1196 Result := TEncoding.BigEndianUnicode 1203 Result := TEncoding.BigEndianUnicode
1197 else if Utf8Test = UTF8_BOM then 1204 else if Utf8Test = UTF8_BOM then
1198 Result := TEncoding.UTF8 1205 Result := TEncoding.UTF8
1199 else begin 1206 else begin
1200 { @note Taken from SynUnicode.pas } 1207 { @note Taken from SynUnicode.pas }
1201 { If no BOM was found, check for leading/trailing byte sequences, 1208 { If no BOM was found, check for leading/trailing byte sequences,
1202 which are uncommon in usual non UTF-8 encoded text. 1209 which are uncommon in usual non UTF-8 encoded text.
1203 1210
1204 NOTE: There is no 100% save way to detect UTF-8 streams. The bigger 1211 NOTE: There is no 100% save way to detect UTF-8 streams. The bigger
1205 MinimumCountOfUTF8Strings, the lower is the probability of 1212 MinimumCountOfUTF8Strings, the lower is the probability of
1206 a false positive. On the other hand, a big MinimumCountOfUTF8Strings 1213 a false positive. On the other hand, a big MinimumCountOfUTF8Strings
1207 makes it unlikely to detect files with only little usage of non 1214 makes it unlikely to detect files with only little usage of non
1208 US-ASCII chars, like usual in European languages. } 1215 US-ASCII chars, like usual in European languages. }
1209 1216
1210 // if no special characteristics are found it is not UTF-8 1217 // if no special characteristics are found it is not UTF-8
1211 Result := TEncoding.Default; 1218 Result := TEncoding.Default;
1212 1219
1213 // start analysis at actual Stream.Position 1220 // start analysis at actual Stream.Position
1214 BufferSize := Min(MaxBufferSize, Stream.Size - Stream.Position); 1221 BufferSize := Min(MaxBufferSize, Stream.Size - Stream.Position);
1215 1222
1216 if BufferSize > 0 then begin 1223 if BufferSize > 0 then begin
1217 SetLength(Buffer, BufferSize); 1224 SetLength(Buffer, BufferSize);
1218 Stream.ReadBuffer(Buffer[0], BufferSize); 1225 Stream.ReadBuffer(Buffer[0], BufferSize);
1219 Stream.Seek(-BufferSize, soFromCurrent); 1226 Stream.Seek(-BufferSize, soFromCurrent);
1220 1227
1221 FoundUTF8Strings := 0; 1228 FoundUTF8Strings := 0;
1222 i := 0; 1229 i := 0;
1223 while i < BufferSize do begin 1230 while i < BufferSize do begin
1224 if FoundUTF8Strings = MinimumCountOfUTF8Strings then begin 1231 if FoundUTF8Strings = MinimumCountOfUTF8Strings then begin
1225 Result := TEncoding.UTF8; 1232 Result := TEncoding.UTF8;
1226 Break; 1233 Break;
1227 end; 1234 end;
1228 case Buffer[i] of 1235 case Buffer[i] of
1229 $00..$7F: // skip US-ASCII characters as they could belong to various charsets 1236 $00..$7F: // skip US-ASCII characters as they could belong to various charsets
1230 ; 1237 ;
1231 $C2..$DF: 1238 $C2..$DF:
1232 if CountOfTrailingBytes = 1 then 1239 if CountOfTrailingBytes = 1 then
1233 inc(FoundUTF8Strings) 1240 inc(FoundUTF8Strings)
1234 else 1241 else
1235 Break; 1242 Break;
1236 $E0: 1243 $E0:
1237 begin 1244 begin
1238 inc(i); 1245 inc(i);
1239 if (i < BufferSize) and (Buffer[i] in [$A0..$BF]) and (CountOfTrailingBytes = 1) then 1246 if (i < BufferSize) and (Buffer[i] in [$A0..$BF]) and (CountOfTrailingBytes = 1) then
1240 inc(FoundUTF8Strings) 1247 inc(FoundUTF8Strings)
1241 else 1248 else
1242 Break; 1249 Break;
1243 end; 1250 end;
1244 $E1..$EC, $EE..$EF: 1251 $E1..$EC, $EE..$EF:
1245 if CountOfTrailingBytes = 2 then 1252 if CountOfTrailingBytes = 2 then
1246 inc(FoundUTF8Strings) 1253 inc(FoundUTF8Strings)
1247 else 1254 else
1248 Break; 1255 Break;
1249 $ED: 1256 $ED:
1250 begin 1257 begin
1251 inc(i); 1258 inc(i);
1252 if (i < BufferSize) and (Buffer[i] in [$80..$9F]) and (CountOfTrailingBytes = 1) then 1259 if (i < BufferSize) and (Buffer[i] in [$80..$9F]) and (CountOfTrailingBytes = 1) then
1253 inc(FoundUTF8Strings) 1260 inc(FoundUTF8Strings)
1254 else 1261 else
1255 Break; 1262 Break;
1256 end; 1263 end;
1257 $F0: 1264 $F0:
1258 begin 1265 begin
1259 inc(i); 1266 inc(i);
1260 if (i < BufferSize) and (Buffer[i] in [$90..$BF]) and (CountOfTrailingBytes = 2) then 1267 if (i < BufferSize) and (Buffer[i] in [$90..$BF]) and (CountOfTrailingBytes = 2) then
1261 inc(FoundUTF8Strings) 1268 inc(FoundUTF8Strings)
1262 else 1269 else
1263 Break; 1270 Break;
1264 end; 1271 end;
1265 $F1..$F3: 1272 $F1..$F3:
1266 if CountOfTrailingBytes = 3 then 1273 if CountOfTrailingBytes = 3 then
1267 inc(FoundUTF8Strings) 1274 inc(FoundUTF8Strings)
1268 else 1275 else
1269 Break; 1276 Break;
1270 $F4: 1277 $F4:
1271 begin 1278 begin
1272 inc(i); 1279 inc(i);
1273 if (i < BufferSize) and (Buffer[i] in [$80..$8F]) and (CountOfTrailingBytes = 2) then 1280 if (i < BufferSize) and (Buffer[i] in [$80..$8F]) and (CountOfTrailingBytes = 2) then
1274 inc(FoundUTF8Strings) 1281 inc(FoundUTF8Strings)
1275 else 1282 else
1276 Break; 1283 Break;
1277 end; 1284 end;
1278 $C0, $C1, $F5..$FF: // invalid UTF-8 bytes 1285 $C0, $C1, $F5..$FF: // invalid UTF-8 bytes
1279 Break; 1286 Break;
1280 $80..$BF: // trailing bytes are consumed when handling leading bytes, 1287 $80..$BF: // trailing bytes are consumed when handling leading bytes,
1281 // any occurence of "orphaned" trailing bytes is invalid UTF-8 1288 // any occurence of "orphaned" trailing bytes is invalid UTF-8
1282 Break; 1289 Break;
1283 end; 1290 end;
1284 inc(i); 1291 inc(i);
1285 end; 1292 end;
1286 end; 1293 end;
1287 end; 1294 end;
1288 end; 1295 end;
1289 1296
1290 1297
1291 {** 1298 {**
1292 Read a chunk out of a textfile unicode safe by passing a stream and its charset 1299 Read a chunk out of a textfile unicode safe by passing a stream and its charset
1293 } 1300 }
1294 function ReadTextfileChunk(Stream: TFileStream; Encoding: TEncoding; ChunkSize: Int64 = 0): String; 1301 function ReadTextfileChunk(Stream: TFileStream; Encoding: TEncoding; ChunkSize: Int64 = 0): String;
1295 var 1302 var
1296 DataLeft: Int64; 1303 DataLeft: Int64;
1297 LBuffer: TBytes; 1304 LBuffer: TBytes;
1298 begin 1305 begin
1299 DataLeft := Stream.Size - Stream.Position; 1306 DataLeft := Stream.Size - Stream.Position;
1300 if (ChunkSize = 0) or (ChunkSize > DataLeft) then 1307 if (ChunkSize = 0) or (ChunkSize > DataLeft) then
1301 ChunkSize := DataLeft; 1308 ChunkSize := DataLeft;
1302 SetLength(LBuffer, ChunkSize); 1309 SetLength(LBuffer, ChunkSize);
1303 Stream.ReadBuffer(Pointer(LBuffer)^, ChunkSize); 1310 Stream.ReadBuffer(Pointer(LBuffer)^, ChunkSize);
1304 LBuffer := Encoding.Convert(Encoding, TEncoding.Unicode, LBuffer, 0, Length(LBuffer)); 1311 LBuffer := Encoding.Convert(Encoding, TEncoding.Unicode, LBuffer, 0, Length(LBuffer));
1305 Result := TEncoding.Unicode.GetString(LBuffer); 1312 Result := TEncoding.Unicode.GetString(LBuffer);
1306 end; 1313 end;
1307 1314
1308 {** 1315 {**
1309 Read a unicode or ansi file into memory 1316 Read a unicode or ansi file into memory
1310 } 1317 }
1311 function ReadTextfile(Filename: String; Encoding: TEncoding): String; 1318 function ReadTextfile(Filename: String; Encoding: TEncoding): String;
1312 var 1319 var
1313 Stream: TFileStream; 1320 Stream: TFileStream;
1314 begin 1321 begin
1315 OpenTextfile(Filename, Stream, Encoding); 1322 OpenTextfile(Filename, Stream, Encoding);
1316 Result := ReadTextfileChunk(Stream, Encoding); 1323 Result := ReadTextfileChunk(Stream, Encoding);
1317 Stream.Free; 1324 Stream.Free;
1318 end; 1325 end;
1319 1326
1320 function ReadBinaryFile(Filename: String; MaxBytes: Int64): AnsiString; 1327 function ReadBinaryFile(Filename: String; MaxBytes: Int64): AnsiString;
1321 var 1328 var
1322 Stream: TFileStream; 1329 Stream: TFileStream;
1323 begin 1330 begin
1324 Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone); 1331 Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone);
1325 Stream.Position := 0; 1332 Stream.Position := 0;
1326 if (MaxBytes < 1) or (MaxBytes > Stream.Size) then MaxBytes := Stream.Size; 1333 if (MaxBytes < 1) or (MaxBytes > Stream.Size) then MaxBytes := Stream.Size;
1327 SetLength(Result, MaxBytes); 1334 SetLength(Result, MaxBytes);
1328 Stream.Read(PAnsiChar(Result)^, Length(Result)); 1335 Stream.Read(PAnsiChar(Result)^, Length(Result));
1329 Stream.Free; 1336 Stream.Free;
1330 end; 1337 end;
1331 1338
1332 1339
1333 procedure StreamToClipboard(Text, HTML: TStream; CreateHTMLHeader: Boolean); 1340 procedure StreamToClipboard(Text, HTML: TStream; CreateHTMLHeader: Boolean);
1334 var 1341 var
1335 TextContent, HTMLContent: AnsiString; 1342 TextContent, HTMLContent: AnsiString;
1336 GlobalMem: HGLOBAL; 1343 GlobalMem: HGLOBAL;
1337 lp: PChar; 1344 lp: PChar;
1338 ClpLen: Integer; 1345 ClpLen: Integer;
1339 CF_HTML: Word; 1346 CF_HTML: Word;
1340 begin 1347 begin
1341 // Copy unicode text to clipboard 1348 // Copy unicode text to clipboard
1342 if Assigned(Text) then begin 1349 if Assigned(Text) then begin
1343 SetLength(TextContent, Text.Size); 1350 SetLength(TextContent, Text.Size);
1344 Text.Position := 0; 1351 Text.Position := 0;
1345 Text.Read(PAnsiChar(TextContent)^, Text.Size); 1352 Text.Read(PAnsiChar(TextContent)^, Text.Size);
1346 Clipboard.AsText := Utf8ToString(TextContent); 1353 Clipboard.AsText := Utf8ToString(TextContent);
1347 SetString(TextContent, nil, 0); 1354 SetString(TextContent, nil, 0);
1348 end; 1355 end;
1349 1356
1350 if Assigned(HTML) then begin 1357 if Assigned(HTML) then begin
1351 // If wanted, add a HTML portion, so formatted text can be pasted in WYSIWYG 1358 // If wanted, add a HTML portion, so formatted text can be pasted in WYSIWYG
1352 // editors (mostly MS applications). 1359 // editors (mostly MS applications).
1353 // Note that the content is UTF8 encoded ANSI. Using unicode variables results in raw 1360 // Note that the content is UTF8 encoded ANSI. Using unicode variables results in raw
1354 // text pasted in editors. TODO: Find out why and optimize redundant code away by a loop. 1361 // text pasted in editors. TODO: Find out why and optimize redundant code away by a loop.
1355 OpenClipBoard(0); 1362 OpenClipBoard(0);
1356 CF_HTML := RegisterClipboardFormat('HTML Format'); 1363 CF_HTML := RegisterClipboardFormat('HTML Format');
1357 SetLength(HTMLContent, HTML.Size); 1364 SetLength(HTMLContent, HTML.Size);
1358 HTML.Position := 0; 1365 HTML.Position := 0;
1359 HTML.Read(PAnsiChar(HTMLContent)^, HTML.Size); 1366 HTML.Read(PAnsiChar(HTMLContent)^, HTML.Size);
1360 if CreateHTMLHeader then begin 1367 if CreateHTMLHeader then begin
1361 HTMLContent := 'Version:0.9' + CRLF + 1368 HTMLContent := 'Version:0.9' + CRLF +
1362 'StartHTML:000089' + CRLF + 1369 'StartHTML:000089' + CRLF +
1363 'EndHTML:°°°°°°' + CRLF + 1370 'EndHTML:°°°°°°' + CRLF +
1364 'StartFragment:000089' + CRLF + 1371 'StartFragment:000089' + CRLF +
1365 'EndFragment:°°°°°°' + CRLF + 1372 'EndFragment:°°°°°°' + CRLF +
1366 HTMLContent + CRLF; 1373 HTMLContent + CRLF;
1367 HTMLContent := AnsiStrings.StringReplace( 1374 HTMLContent := AnsiStrings.StringReplace(
1368 HTMLContent, '°°°°°°', 1375 HTMLContent, '°°°°°°',
1369 AnsiStrings.Format('%.6d', [Length(HTMLContent)]), 1376 AnsiStrings.Format('%.6d', [Length(HTMLContent)]),
1370 [rfReplaceAll]); 1377 [rfReplaceAll]);
1371 end; 1378 end;
1372 ClpLen := Length(HTMLContent) + 1; 1379 ClpLen := Length(HTMLContent) + 1;
1373 GlobalMem := GlobalAlloc(GMEM_DDESHARE + GMEM_MOVEABLE, ClpLen); 1380 GlobalMem := GlobalAlloc(GMEM_DDESHARE + GMEM_MOVEABLE, ClpLen);
1374 lp := GlobalLock(GlobalMem); 1381 lp := GlobalLock(GlobalMem);
1375 Move(PAnsiChar(HTMLContent)^, lp[0], ClpLen); 1382 Move(PAnsiChar(HTMLContent)^, lp[0], ClpLen);
1376 SetString(HTMLContent, nil, 0); 1383 SetString(HTMLContent, nil, 0);
1377 GlobalUnlock(GlobalMem); 1384 GlobalUnlock(GlobalMem);
1378 SetClipboardData(CF_HTML, GlobalMem); 1385 SetClipboardData(CF_HTML, GlobalMem);
1379 CloseClipboard; 1386 CloseClipboard;
1380 end; 1387 end;
1381 end; 1388 end;
1382 1389
1383 1390
1384 procedure FixVT(VT: TVirtualStringTree; MultiLineCount: Word=1); 1391 procedure FixVT(VT: TVirtualStringTree; MultiLineCount: Word=1);
1385 var 1392 var
1386 SingleLineHeight: Integer; 1393 SingleLineHeight: Integer;
1387 Node: PVirtualNode; 1394 Node: PVirtualNode;
1388 begin 1395 begin
1389 // Resize hardcoded node height to work with different DPI settings 1396 // Resize hardcoded node height to work with different DPI settings
1390 VT.BeginUpdate; 1397 VT.BeginUpdate;
1391 SingleLineHeight := GetTextHeight(VT.Font); 1398 SingleLineHeight := GetTextHeight(VT.Font);
1392 VT.DefaultNodeHeight := SingleLineHeight * MultiLineCount + 5; 1399 VT.DefaultNodeHeight := SingleLineHeight * MultiLineCount + 5;
1393 // The header needs slightly more height than the normal nodes 1400 // The header needs slightly more height than the normal nodes
1394 VT.Header.Height := Trunc(SingleLineHeight * 1.5); 1401 VT.Header.Height := Trunc(SingleLineHeight * 1.5);
1395 // Apply new height to multi line grid nodes 1402 // Apply new height to multi line grid nodes
1396 Node := VT.GetFirstInitialized; 1403 Node := VT.GetFirstInitialized;
1397 while Assigned(Node) do begin 1404 while Assigned(Node) do begin
1398 VT.NodeHeight[Node] := VT.DefaultNodeHeight; 1405 VT.NodeHeight[Node] := VT.DefaultNodeHeight;
1399 VT.MultiLine[Node] := MultiLineCount > 1; 1406 VT.MultiLine[Node] := MultiLineCount > 1;
1400 Node := VT.GetNextInitialized(Node); 1407 Node := VT.GetNextInitialized(Node);
1401 end; 1408 end;
1402 VT.EndUpdate; 1409 VT.EndUpdate;
1403 // Disable hottracking in non-Vista mode, looks ugly in XP, but nice in Vista 1410 // Disable hottracking in non-Vista mode, looks ugly in XP, but nice in Vista
1404 if (toUseExplorerTheme in VT.TreeOptions.PaintOptions) and (Win32MajorVersion >= 6) then 1411 if (toUseExplorerTheme in VT.TreeOptions.PaintOptions) and (Win32MajorVersion >= 6) then
1405 VT.TreeOptions.PaintOptions := VT.TreeOptions.PaintOptions + [toHotTrack] 1412 VT.TreeOptions.PaintOptions := VT.TreeOptions.PaintOptions + [toHotTrack]
1406 else 1413 else
1407 VT.TreeOptions.PaintOptions := VT.TreeOptions.PaintOptions - [toHotTrack]; 1414 VT.TreeOptions.PaintOptions := VT.TreeOptions.PaintOptions - [toHotTrack];
1408 VT.OnGetHint := MainForm.AnyGridGetHint; 1415 VT.OnGetHint := MainForm.AnyGridGetHint;
1409 VT.OnScroll := MainForm.AnyGridScroll; 1416 VT.OnScroll := MainForm.AnyGridScroll;
1410 VT.OnMouseWheel := MainForm.AnyGridMouseWheel; 1417 VT.OnMouseWheel := MainForm.AnyGridMouseWheel;
1411 VT.ShowHint := True; 1418 VT.ShowHint := True;
1412 VT.HintMode := hmToolTip; 1419 VT.HintMode := hmToolTip;
1413 // Apply case insensitive incremental search event 1420 // Apply case insensitive incremental search event
1414 if VT.IncrementalSearch <> isNone then 1421 if VT.IncrementalSearch <> isNone then
1415 VT.OnIncrementalSearch := Mainform.AnyGridIncrementalSearch; 1422 VT.OnIncrementalSearch := Mainform.AnyGridIncrementalSearch;
1416 VT.OnStartOperation := Mainform.AnyGridStartOperation; 1423 VT.OnStartOperation := Mainform.AnyGridStartOperation;
1417 VT.OnEndOperation := Mainform.AnyGridEndOperation; 1424 VT.OnEndOperation := Mainform.AnyGridEndOperation;
1418 end; 1425 end;
1419 1426
1420 1427
1421 function GetTextHeight(Font: TFont): Integer; 1428 function GetTextHeight(Font: TFont): Integer;
1422 var 1429 var
1423 DC: HDC; 1430 DC: HDC;
1424 SaveFont: HFont; 1431 SaveFont: HFont;
1425 SysMetrics, Metrics: TTextMetric; 1432 SysMetrics, Metrics: TTextMetric;
1426 begin 1433 begin
1427 // Code taken from StdCtrls.TCustomEdit.AdjustHeight 1434 // Code taken from StdCtrls.TCustomEdit.AdjustHeight
1428 DC := GetDC(0); 1435 DC := GetDC(0);
1429 GetTextMetrics(DC, SysMetrics); 1436 GetTextMetrics(DC, SysMetrics);
1430 SaveFont := SelectObject(DC, Font.Handle); 1437 SaveFont := SelectObject(DC, Font.Handle);
1431 GetTextMetrics(DC, Metrics); 1438 GetTextMetrics(DC, Metrics);
1432 SelectObject(DC, SaveFont); 1439 SelectObject(DC, SaveFont);
1433 ReleaseDC(0, DC); 1440 ReleaseDC(0, DC);
1434 Result := Metrics.tmHeight; 1441 Result := Metrics.tmHeight;
1435 end; 1442 end;
1436 1443
1437 1444
1438 function ColorAdjustBrightness(Col: TColor; Shift: SmallInt): TColor; 1445 function ColorAdjustBrightness(Col: TColor; Shift: SmallInt): TColor;
1439 var 1446 var
1440 Lightness: Byte; 1447 Lightness: Byte;
1441 begin 1448 begin
1442 // If base color is bright, make bg color darker (grey), and vice versa, so that 1449 // If base color is bright, make bg color darker (grey), and vice versa, so that
1443 // colors work with high contrast mode for accessibility 1450 // colors work with high contrast mode for accessibility
1444 Lightness := GetLightness(Col); 1451 Lightness := GetLightness(Col);
1445 if (Lightness < 128) and (Shift < 0) then 1452 if (Lightness < 128) and (Shift < 0) then
1446 Shift := Abs(Shift) 1453 Shift := Abs(Shift)
1447 else if (Lightness > 128) and (Shift > 0) then 1454 else if (Lightness > 128) and (Shift > 0) then
1448 Shift := 0 - Abs(Shift); 1455 Shift := 0 - Abs(Shift);
1449 Result := ColorAdjustLuma(Col, Shift, true); 1456 Result := ColorAdjustLuma(Col, Shift, true);
1450 end; 1457 end;
1451 1458
1452 1459
1453 {** 1460 {**
1454 Concat all sort options to a ORDER clause 1461 Concat all sort options to a ORDER clause
1455 } 1462 }
1456 function ComposeOrderClause(Cols: TOrderColArray): String; 1463 function ComposeOrderClause(Cols: TOrderColArray): String;
1457 var 1464 var
1458 i : Integer; 1465 i : Integer;
1459 sort : String; 1466 sort : String;
1460 begin 1467 begin
1461 result := ''; 1468 result := '';
1462 for i := 0 to Length(Cols) - 1 do 1469 for i := 0 to Length(Cols) - 1 do
1463 begin 1470 begin
1464 if result <> '' then 1471 if result <> '' then
1465 result := result + ', '; 1472 result := result + ', ';
1466 if Cols[i].SortDirection = ORDER_ASC then 1473 if Cols[i].SortDirection = ORDER_ASC then
1467 sort := TXT_ASC 1474 sort := TXT_ASC
1468 else 1475 else
1469 sort := TXT_DESC; 1476 sort := TXT_DESC;
1470 result := result + MainForm.ActiveConnection.QuoteIdent( Cols[i].ColumnName ) + ' ' + sort; 1477 result := result + MainForm.ActiveConnection.QuoteIdent( Cols[i].ColumnName ) + ' ' + sort;
1471 end; 1478 end;
1472 end; 1479 end;
1473 1480
1474 1481
1475 {** 1482 {**
1476 Init main registry object and open desired key 1483 Init main registry object and open desired key
1477 Outsoureced from GetRegValue() to avoid redundant code 1484 Outsoureced from GetRegValue() to avoid redundant code
1478 in these 3 overloaded methods. 1485 in these 3 overloaded methods.
1479 } 1486 }
1480 procedure OpenRegistry(Session: String = ''); 1487 procedure OpenRegistry(Session: String = '');
1481 var 1488 var
1482 folder : String; 1489 folder : String;
1483 begin 1490 begin
1484 if MainReg = nil then begin 1491 if MainReg = nil then begin
1485 MainReg := TRegistry.Create; 1492 MainReg := TRegistry.Create;
1486 HandlePortableSettings(True); 1493 HandlePortableSettings(True);
1487 end; 1494 end;
1488 folder := RegPath; 1495 folder := RegPath;
1489 if Session <> '' then 1496 if Session <> '' then
1490 folder := folder + REGKEY_SESSIONS + Session; 1497 folder := folder + REGKEY_SESSIONS + Session;
1491 if MainReg.CurrentPath <> folder then 1498 if MainReg.CurrentPath <> folder then
1492 MainReg.OpenKey(folder, true); 1499 MainReg.OpenKey(folder, true);
1493 end; 1500 end;
1494 1501
1495 1502
1496 {** 1503 {**
1497 Read a numeric preference value from registry 1504 Read a numeric preference value from registry
1498 } 1505 }
1499 function GetRegValue( valueName: String; defaultValue: Integer; Session: String = '' ) : Integer; 1506 function GetRegValue( valueName: String; defaultValue: Integer; Session: String = '' ) : Integer;
1500 begin 1507 begin
1501 result := defaultValue; 1508 result := defaultValue;
1502 OpenRegistry(Session); 1509 OpenRegistry(Session);
1503 if MainReg.ValueExists( valueName ) then 1510 if MainReg.ValueExists( valueName ) then
1504 result := MainReg.ReadInteger( valueName ); 1511 result := MainReg.ReadInteger( valueName );
1505 end; 1512 end;
1506 1513
1507 1514
1508 {*** 1515 {***
1509 Read a boolean preference value from registry 1516 Read a boolean preference value from registry
1510 @param string Name of the value 1517 @param string Name of the value
1511 @param boolean Default-value to return if valueName was not found 1518 @param boolean Default-value to return if valueName was not found
1512 @param string Subkey of RegPath where to search for the value 1519 @param string Subkey of RegPath where to search for the value
1513 } 1520 }
1514 function GetRegValue( valueName: String; defaultValue: Boolean; Session: String = '' ) : Boolean; 1521 function GetRegValue( valueName: String; defaultValue: Boolean; Session: String = '' ) : Boolean;
1515 begin 1522 begin
1516 result := defaultValue; 1523 result := defaultValue;
1517 OpenRegistry(Session); 1524 OpenRegistry(Session);
1518 if MainReg.ValueExists( valueName ) then 1525 if MainReg.ValueExists( valueName ) then
1519 result := MainReg.ReadBool( valueName ); 1526 result := MainReg.ReadBool( valueName );
1520 end; 1527 end;
1521 1528
1522 1529
1523 1530
1524 {*** 1531 {***
1525 Read a text preference value from registry 1532 Read a text preference value from registry
1526 } 1533 }
1527 function GetRegValue( valueName: String; defaultValue: String; Session: String = '' ) : String; 1534 function GetRegValue( valueName: String; defaultValue: String; Session: String = '' ) : String;
1528 begin 1535 begin
1529 result := defaultValue; 1536 result := defaultValue;
1530 OpenRegistry(Session); 1537 OpenRegistry(Session);
1531 if MainReg.ValueExists( valueName ) then 1538 if MainReg.ValueExists( valueName ) then
1532 result := MainReg.ReadString( valueName ); 1539 result := MainReg.ReadString( valueName );
1533 end; 1540 end;
1534 1541
1535 1542
1536 procedure DeInitializeVTNodes(Sender: TBaseVirtualTree); 1543 procedure DeInitializeVTNodes(Sender: TBaseVirtualTree);
1537 var 1544 var
1538 Node: PVirtualNode; 1545 Node: PVirtualNode;
1539 begin 1546 begin
1540 // Forces a VirtualTree to (re-)initialize its nodes. 1547 // Forces a VirtualTree to (re-)initialize its nodes.
1541 // I wonder why this is not implemented in VirtualTree. 1548 // I wonder why this is not implemented in VirtualTree.
1542 Node := Sender.GetFirstInitialized; 1549 Node := Sender.GetFirstInitialized;
1543 while Assigned(Node) do begin 1550 while Assigned(Node) do begin
1544 Node.States := Node.States - [vsInitialized]; 1551 Node.States := Node.States - [vsInitialized];
1545 Node := Sender.GetNextInitialized(Node); 1552 Node := Sender.GetNextInitialized(Node);
1546 end; 1553 end;
1547 end; 1554 end;
1548 1555
1549 1556
1550 function ListIndexByRegExpr(List: TStrings; Expression: String): Integer; 1557 function ListIndexByRegExpr(List: TStrings; Expression: String): Integer;
1551 var 1558 var
1552 rx: TRegExpr; 1559 rx: TRegExpr;
1553 i: Integer; 1560 i: Integer;
1554 begin 1561 begin
1555 // Find item in stringlist by passing a regular expression 1562 // Find item in stringlist by passing a regular expression
1556 rx := TRegExpr.Create; 1563 rx := TRegExpr.Create;
1557 rx.Expression := Expression; 1564 rx.Expression := Expression;
1558 rx.ModifierI := True; 1565 rx.ModifierI := True;
1559 Result := -1; 1566 Result := -1;
1560 for i := 0 to List.Count - 1 do begin 1567 for i := 0 to List.Count - 1 do begin
1561 if rx.Exec(List[i]) then begin 1568 if rx.Exec(List[i]) then begin
1562 Result := i; 1569 Result := i;
1563 break; 1570 break;
1564 end; 1571 end;
1565 end; 1572 end;
1566 FreeAndNil(rx); 1573 FreeAndNil(rx);
1567 end; 1574 end;
1568 1575
1569 1576
1570 function FindNode(VT: TVirtualStringTree; idx: Cardinal; ParentNode: PVirtualNode): PVirtualNode; 1577 function FindNode(VT: TVirtualStringTree; idx: Cardinal; ParentNode: PVirtualNode): PVirtualNode;
1571 var 1578 var
1572 Node: PVirtualNode; 1579 Node: PVirtualNode;
1573 begin 1580 begin
1574 // Helper to find a node by its index 1581 // Helper to find a node by its index
1575 Result := nil; 1582 Result := nil;
1576 if Assigned(ParentNode) then 1583 if Assigned(ParentNode) then
1577 Node := VT.GetFirstChild(ParentNode) 1584 Node := VT.GetFirstChild(ParentNode)
1578 else 1585 else
1579 Node := VT.GetFirst; 1586 Node := VT.GetFirst;
1580 while Assigned(Node) do begin 1587 while Assigned(Node) do begin
1581 if Node.Index = idx then begin 1588 if Node.Index = idx then begin
1582 Result := Node; 1589 Result := Node;
1583 break; 1590 break;
1584 end; 1591 end;
1585 Node := VT.GetNextSibling(Node); 1592 Node := VT.GetNextSibling(Node);
1586 end; 1593 end;
1587 end; 1594 end;
1588 1595
1589 1596
1590 procedure SelectNode(VT: TVirtualStringTree; idx: Cardinal; ParentNode: PVirtualNode=nil); overload; 1597 procedure SelectNode(VT: TVirtualStringTree; idx: Cardinal; ParentNode: PVirtualNode=nil); overload;
1591 var 1598 var
1592 Node: PVirtualNode; 1599 Node: PVirtualNode;
1593 begin 1600 begin
1594 // Helper to focus and highlight a node by its index 1601 // Helper to focus and highlight a node by its index
1595 Node := FindNode(VT, idx, ParentNode); 1602 Node := FindNode(VT, idx, ParentNode);
1596 if Assigned(Node) then 1603 if Assigned(Node) then
1597 SelectNode(VT, Node); 1604 SelectNode(VT, Node);
1598 end; 1605 end;
1599 1606
1600 1607
1601 procedure SelectNode(VT: TVirtualStringTree; Node: PVirtualNode); overload; 1608 procedure SelectNode(VT: TVirtualStringTree; Node: PVirtualNode); overload;
1602 var 1609 var
1603 OldFocus: PVirtualNode; 1610 OldFocus: PVirtualNode;
1604 begin 1611 begin
1605 OldFocus := VT.FocusedNode; 1612 OldFocus := VT.FocusedNode;
1606 VT.ClearSelection; 1613 VT.ClearSelection;
1607 VT.FocusedNode := Node; 1614 VT.FocusedNode := Node;
1608 VT.Selected[Node] := True; 1615 VT.Selected[Node] := True;
1609 VT.ScrollIntoView(Node, False); 1616 VT.ScrollIntoView(Node, False);
1610 if (OldFocus = Node) and Assigned(VT.OnFocusChanged) then 1617 if (OldFocus = Node) and Assigned(VT.OnFocusChanged) then
1611 VT.OnFocusChanged(VT, Node, VT.Header.MainColumn); 1618 VT.OnFocusChanged(VT, Node, VT.Header.MainColumn);
1612 end; 1619 end;
1613 1620
1614 1621
1615 function GetVTSelection(VT: TVirtualStringTree): TStringList; 1622 function GetVTSelection(VT: TVirtualStringTree): TStringList;
1616 var 1623 var
1617 Node: PVirtualNode; 1624 Node: PVirtualNode;
1618 InvalidationTag: Integer; 1625 InvalidationTag: Integer;
1619 begin 1626 begin
1620 // Return captions of selected nodes 1627 // Return captions of selected nodes
1621 InvalidationTag := vt.Tag; 1628 InvalidationTag := vt.Tag;
1622 vt.Tag := VTREE_LOADED; 1629 vt.Tag := VTREE_LOADED;
1623 Result := TStringList.Create; 1630 Result := TStringList.Create;
1624 Node := GetNextNode(VT, nil, true); 1631 Node := GetNextNode(VT, nil, true);
1625 while Assigned(Node) do begin 1632 while Assigned(Node) do begin
1626 Result.Add(VT.Text[Node, VT.Header.MainColumn]); 1633 Result.Add(VT.Text[Node, VT.Header.MainColumn]);
1627 Node := GetNextNode(VT, Node, true); 1634 Node := GetNextNode(VT, Node, true);
1628 end; 1635 end;
1629 vt.Tag := InvalidationTag; 1636 vt.Tag := InvalidationTag;
1630 end; 1637 end;
1631 1638
1632 1639
1633 procedure SetVTSelection(VT: TVirtualStringTree; Captions: TStringList); 1640 procedure SetVTSelection(VT: TVirtualStringTree; Captions: TStringList);
1634 var 1641 var
1635 Node: PVirtualNode; 1642 Node: PVirtualNode;
1636 idx: Integer; 1643 idx: Integer;
1637 begin 1644 begin
1638 // Restore selected nodes based on captions list 1645 // Restore selected nodes based on captions list
1639 Node := GetNextNode(VT, nil, false); 1646 Node := GetNextNode(VT, nil, false);
1640 while Assigned(Node) do begin 1647 while Assigned(Node) do begin
1641 idx := Captions.IndexOf(VT.Text[Node, VT.Header.MainColumn]); 1648 idx := Captions.IndexOf(VT.Text[Node, VT.Header.MainColumn]);
1642 if idx > -1 then 1649 if idx > -1 then
1643 VT.Selected[Node] := True; 1650 VT.Selected[Node] := True;
1644 Node := GetNextNode(VT, Node, false); 1651 Node := GetNextNode(VT, Node, false);
1645 end; 1652 end;
1646 end; 1653 end;
1647 1654
1648 1655
1649 function GetNextNode(Tree: TVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode; 1656 function GetNextNode(Tree: TVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode;
1650 begin 1657 begin
1651 // Get next visible + selected node. Not possible with VTree's own functions. 1658 // Get next visible + selected node. Not possible with VTree's own functions.
1652 Result := CurrentNode; 1659 Result := CurrentNode;
1653 while True do begin 1660 while True do begin
1654 if Selected then begin 1661 if Selected then begin
1655 if not Assigned(Result) then 1662 if not Assigned(Result) then
1656 Result := Tree.GetFirstSelected 1663 Result := Tree.GetFirstSelected
1657 else 1664 else
1658 Result := Tree.GetNextSelected(Result); 1665 Result := Tree.GetNextSelected(Result);
1659 end else begin 1666 end else begin
1660 if not Assigned(Result) then 1667 if not Assigned(Result) then
1661 Result := Tree.GetFirst 1668 Result := Tree.GetFirst
1662 else 1669 else
1663 Result := Tree.GetNext(Result); 1670 Result := Tree.GetNext(Result);
1664 end; 1671 end;
1665 if (not Assigned(Result)) or Tree.IsVisible[Result] then 1672 if (not Assigned(Result)) or Tree.IsVisible[Result] then
1666 break; 1673 break;
1667 end; 1674 end;
1668 end; 1675 end;
1669 1676
1670 1677
1671 function DateBackFriendlyCaption(d: TDateTime): String; 1678 function DateBackFriendlyCaption(d: TDateTime): String;
1672 var 1679 var
1673 MonthsAgo, DaysAgo, HoursAgo, MinutesAgo: Int64; 1680 MonthsAgo, DaysAgo, HoursAgo, MinutesAgo: Int64;
1674 begin 1681 begin
1675 MonthsAgo := MonthsBetween(Now, d); 1682 MonthsAgo := MonthsBetween(Now, d);
1676 DaysAgo := DaysBetween(Now, d); 1683 DaysAgo := DaysBetween(Now, d);
1677 HoursAgo := HoursBetween(Now, d); 1684 HoursAgo := HoursBetween(Now, d);
1678 MinutesAgo := MinutesBetween(Now, d); 1685 MinutesAgo := MinutesBetween(Now, d);
1679 if MonthsAgo = 1 then Result := FormatNumber(MonthsAgo)+' month ago' 1686 if MonthsAgo = 1 then Result := FormatNumber(MonthsAgo)+' month ago'
1680 else if MonthsAgo > 1 then Result := FormatNumber(MonthsAgo)+' months ago' 1687 else if MonthsAgo > 1 then Result := FormatNumber(MonthsAgo)+' months ago'
1681 else if DaysAgo = 1 then Result := FormatNumber(DaysAgo)+' day ago' 1688 else if DaysAgo = 1 then Result := FormatNumber(DaysAgo)+' day ago'
1682 else if DaysAgo > 1 then Result := FormatNumber(DaysAgo)+' days ago' 1689 else if DaysAgo > 1 then Result := FormatNumber(DaysAgo)+' days ago'
1683 else if HoursAgo = 1 then Result := FormatNumber(HoursAgo)+' hour ago' 1690 else if HoursAgo = 1 then Result := FormatNumber(HoursAgo)+' hour ago'
1684 else if HoursAgo > 1 then Result := FormatNumber(HoursAgo)+' hours ago' 1691 else if HoursAgo > 1 then Result := FormatNumber(HoursAgo)+' hours ago'
1685 else if MinutesAgo = 1 then Result := FormatNumber(MinutesAgo)+' minute ago' 1692 else if MinutesAgo = 1 then Result := FormatNumber(MinutesAgo)+' minute ago'
1686 else if MinutesAgo > 0 then Result := FormatNumber(MinutesAgo)+' minutes ago' 1693 else if MinutesAgo > 0 then Result := FormatNumber(MinutesAgo)+' minutes ago'
1687 else Result := 'less than a minute ago'; 1694 else Result := 'less than a minute ago';
1688 end; 1695 end;
1689 1696
1690 1697
1691 procedure ExplodeQuotedList(Text: String; var List: TStringList); 1698 procedure ExplodeQuotedList(Text: String; var List: TStringList);
1692 var 1699 var
1693 i: Integer; 1700 i: Integer;
1694 Quote: Char; 1701 Quote: Char;
1695 Opened, Closed: Boolean; 1702 Opened, Closed: Boolean;
1696 Item: String; 1703 Item: String;
1697 begin 1704 begin
1698 Text := Trim(Text); 1705 Text := Trim(Text);
1699 if Length(Text) > 0 then 1706 if Length(Text) > 0 then
1700 Quote := Text[1] 1707 Quote := Text[1]
1701 else 1708 else
1702 Quote := '`'; 1709 Quote := '`';
1703 Opened := False; 1710 Opened := False;
1704 Closed := True; 1711 Closed := True;
1705 Item := ''; 1712 Item := '';
1706 for i:=1 to Length(Text) do begin 1713 for i:=1 to Length(Text) do begin
1707 if Text[i] = Quote then begin 1714 if Text[i] = Quote then begin
1708 Opened := not Opened; 1715 Opened := not Opened;
1709 Closed := not Closed; 1716 Closed := not Closed;
1710 if Closed then begin 1717 if Closed then begin
1711 List.Add(Item); 1718 List.Add(Item);
1712 Item := ''; 1719 Item := '';
1713 end; 1720 end;
1714 Continue; 1721 Continue;
1715 end; 1722 end;
1716 if Opened and (not Closed) then 1723 if Opened and (not Closed) then
1717 Item := Item + Text[i]; 1724 Item := Item + Text[i];
1718 end; 1725 end;
1719 end; 1726 end;
1720 1727
1721 1728
1722 procedure InheritFont(AFont: TFont); 1729 procedure InheritFont(AFont: TFont);
1723 begin 1730 begin
1724 AFont.Name := Mainform.Font.Name; 1731 AFont.Name := Mainform.Font.Name;
1725 AFont.Size := Mainform.Font.Size; 1732 AFont.Size := Mainform.Font.Size;
1726 end; 1733 end;
1727 1734
1728 1735
1729 function GetLightness(AColor: TColor): Byte; 1736 function GetLightness(AColor: TColor): Byte;
1730 var 1737 var
1731 R, G, B: Byte; 1738 R, G, B: Byte;
1732 MaxValue, MinValue: Double; 1739 MaxValue, MinValue: Double;
1733 Lightness: Double; 1740 Lightness: Double;
1734 begin 1741 begin
1735 R := GetRValue(ColorToRGB(AColor)); 1742 R := GetRValue(ColorToRGB(AColor));
1736 G := GetGValue(ColorToRGB(AColor)); 1743 G := GetGValue(ColorToRGB(AColor));
1737 B := GetBValue(ColorToRGB(AColor)); 1744 B := GetBValue(ColorToRGB(AColor));
1738 MaxValue := Max(Max(R,G),B); 1745 MaxValue := Max(Max(R,G),B);
1739 MinValue := Min(Min(R,G),B); 1746 MinValue := Min(Min(R,G),B);
1740 Lightness := (((MaxValue + MinValue) * 240) + 255 ) / 510; 1747 Lightness := (((MaxValue + MinValue) * 240) + 255 ) / 510;
1741 Result := Round(Lightness); 1748 Result := Round(Lightness);
1742 end; 1749 end;
1743 1750
1744 1751
1745 function ReformatSQL(SQL: String): String; 1752 function ReformatSQL(SQL: String): String;
1746 var 1753 var
1747 AllKeywords, ImportantKeywords, PairKeywords: TStringList; 1754 AllKeywords, ImportantKeywords, PairKeywords: TStringList;
1748 i, Run, KeywordMaxLen: Integer; 1755 i, Run, KeywordMaxLen: Integer;
1749 IsEsc, IsQuote, InComment, InBigComment, InString, InKeyword, InIdent, LastWasComment: Boolean; 1756 IsEsc, IsQuote, InComment, InBigComment, InString, InKeyword, InIdent, LastWasComment: Boolean;
1750 c, p: Char; 1757 c, p: Char;
1751 Keyword, PreviousKeyword, TestPair: String; 1758 Keyword, PreviousKeyword, TestPair: String;
1752 Datatypes: TDBDataTypeArray; 1759 Datatypes: TDBDataTypeArray;
1753 const 1760 const
1754 WordChars = ['a'..'z', 'A'..'Z', '0'..'9', '_', '.']; 1761 WordChars = ['a'..'z', 'A'..'Z', '0'..'9', '_', '.'];
1755 WhiteSpaces = [#9, #10, #13, #32]; 1762 WhiteSpaces = [#9, #10, #13, #32];
1756 begin 1763 begin
1757 // Known SQL keywords, get converted to UPPERCASE 1764 // Known SQL keywords, get converted to UPPERCASE
1758 AllKeywords := TStringList.Create; 1765 AllKeywords := TStringList.Create;
1759 AllKeywords.Text := MySQLKeywords.Text; 1766 AllKeywords.Text := MySQLKeywords.Text;
1760 for i:=Low(MySQLFunctions) to High(MySQLFunctions) do begin 1767 for i:=Low(MySQLFunctions) to High(MySQLFunctions) do begin
1761 // Leave out operator functions like ">>", and the "X()" function so hex values don't get touched 1768 // Leave out operator functions like ">>", and the "X()" function so hex values don't get touched
1762 if (MySQLFunctions[i].Declaration <> '') and (MySQLFunctions[i].Name <> 'X') then 1769 if (MySQLFunctions[i].Declaration <> '') and (MySQLFunctions[i].Name <> 'X') then
1763 AllKeywords.Add(MySQLFunctions[i].Name); 1770 AllKeywords.Add(MySQLFunctions[i].Name);
1764 end; 1771 end;
1765 Datatypes := Mainform.ActiveConnection.Datatypes; 1772 Datatypes := Mainform.ActiveConnection.Datatypes;
1766 for i:=Low(Datatypes) to High(Datatypes) do 1773 for i:=Low(Datatypes) to High(Datatypes) do
1767 AllKeywords.Add(Datatypes[i].Name); 1774 AllKeywords.Add(Datatypes[i].Name);
1768 KeywordMaxLen := 0; 1775 KeywordMaxLen := 0;
1769 for i:=0 to AllKeywords.Count-1 do 1776 for i:=0 to AllKeywords.Count-1 do
1770 KeywordMaxLen := Max(KeywordMaxLen, Length(AllKeywords[i])); 1777 KeywordMaxLen := Max(KeywordMaxLen, Length(AllKeywords[i]));
1771 1778
1772 // A subset of the above list, each of them will get a linebreak left to it 1779 // A subset of the above list, each of them will get a linebreak left to it
1773 ImportantKeywords := Explode(',', 'SELECT,FROM,LEFT,RIGHT,STRAIGHT,NATURAL,INNER,JOIN,WHERE,GROUP,ORDER,HAVING,LIMIT,CREATE,DROP,UPDATE,INSERT,REPLACE,TRUNCATE,DELETE'); 1780 ImportantKeywords := Explode(',', 'SELECT,FROM,LEFT,RIGHT,STRAIGHT,NATURAL,INNER,JOIN,WHERE,GROUP,ORDER,HAVING,LIMIT,CREATE,DROP,UPDATE,INSERT,REPLACE,TRUNCATE,DELETE');
1774 // Keywords which followers should not get separated into a new line 1781 // Keywords which followers should not get separated into a new line
1775 PairKeywords := Explode(',', 'LEFT,RIGHT,STRAIGHT,NATURAL,INNER,ORDER,GROUP'); 1782 PairKeywords := Explode(',', 'LEFT,RIGHT,STRAIGHT,NATURAL,INNER,ORDER,GROUP');
1776 1783
1777 IsEsc := False; 1784 IsEsc := False;
1778 InComment := False; 1785 InComment := False;
1779 InBigComment := False; 1786 InBigComment := False;
1780 LastWasComment := False; 1787 LastWasComment := False;
1781 InString := False; 1788 InString := False;
1782 InIdent := False; 1789 InIdent := False;
1783 Run := 1; 1790 Run := 1;
1784 Result := ''; 1791 Result := '';
1785 SQL := SQL + ' '; 1792 SQL := SQL + ' ';
1786 SetLength(Result, Length(SQL)*2); 1793 SetLength(Result, Length(SQL)*2);
1787 Keyword := ''; 1794 Keyword := '';
1788 PreviousKeyword := ''; 1795 PreviousKeyword := '';
1789 for i:=1 to Length(SQL) do begin 1796 for i:=1 to Length(SQL) do begin
1790 c := SQL[i]; // Current char 1797 c := SQL[i]; // Current char
1791 if i > 1 then p := SQL[i-1] else p := #0; // Previous char 1798 if i > 1 then p := SQL[i-1] else p := #0; // Previous char
1792 1799
1793 // Detection logic - where are we? 1800 // Detection logic - where are we?
1794 if c = '\' then IsEsc := not IsEsc 1801 if c = '\' then IsEsc := not IsEsc
1795 else IsEsc := False; 1802 else IsEsc := False;
1796 IsQuote := (c = '''') or (c = '"'); 1803 IsQuote := (c = '''') or (c = '"');
1797 if c = '`' then InIdent := not InIdent; 1804 if c = '`' then InIdent := not InIdent;
1798 if (not IsEsc) and IsQuote then InString := not InString; 1805 if (not IsEsc) and IsQuote then InString := not InString;
1799 if (c = '#') or ((c = '-') and (p = '-')) then InComment := True; 1806 if (c = '#') or ((c = '-') and (p = '-')) then InComment := True;
1800 if ((c = #10) or (c = #13)) and InComment then begin 1807 if ((c = #10) or (c = #13)) and InComment then begin
1801 LastWasComment := True; 1808 LastWasComment := True;
1802 InComment := False; 1809 InComment := False;
1803 end; 1810 end;
1804 if (c = '*') and (p = '/') and (not InComment) and (not InString) then InBigComment := True; 1811 if (c = '*') and (p = '/') and (not InComment) and (not InString) then InBigComment := True;
1805 if (c = '/') and (p = '*') and (not InComment) and (not InString) then InBigComment := False; 1812 if (c = '/') and (p = '*') and (not InComment) and (not InString) then InBigComment := False;
1806 InKeyword := (not InComment) and (not InBigComment) and (not InString) and (not InIdent) and CharInSet(c, WordChars); 1813 InKeyword := (not InComment) and (not InBigComment) and (not InString) and (not InIdent) and CharInSet(c, WordChars);
1807 1814
1808 // Creation of returning text 1815 // Creation of returning text
1809 if InKeyword then begin 1816 if InKeyword then begin
1810 Keyword := Keyword + c; 1817 Keyword := Keyword + c;
1811 end else begin 1818 end else begin
1812 if Keyword <> '' then begin 1819 if Keyword <> '' then begin
1813 if AllKeywords.IndexOf(KeyWord) > -1 then begin 1820 if AllKeywords.IndexOf(KeyWord) > -1 then begin
1814 while (Run > 1) and CharInSet(Result[Run-1], WhiteSpaces) do 1821 while (Run > 1) and CharInSet(Result[Run-1], WhiteSpaces) do
1815 Dec(Run); 1822 Dec(Run);
1816 Keyword := UpperCase(Keyword); 1823 Keyword := UpperCase(Keyword);
1817 if Run > 1 then begin 1824 if Run > 1 then begin
1818 // SELECT, WHERE, JOIN etc. get a new line, but don't separate LEFT JOIN with linebreaks 1825 // SELECT, WHERE, JOIN etc. get a new line, but don't separate LEFT JOIN with linebreaks
1819 if LastWasComment or ((ImportantKeywords.IndexOf(Keyword) > -1) and (PairKeywords.IndexOf(PreviousKeyword) = -1)) then 1826 if LastWasComment or ((ImportantKeywords.IndexOf(Keyword) > -1) and (PairKeywords.IndexOf(PreviousKeyword) = -1)) then
1820 Keyword := CRLF + Keyword 1827 Keyword := CRLF + Keyword
1821 else if (Result[Run-1] <> '(') then 1828 else if (Result[Run-1] <> '(') then
1822 Keyword := ' ' + Keyword; 1829 Keyword := ' ' + Keyword;
1823 end; 1830 end;
1824 LastWasComment := False; 1831 LastWasComment := False;
1825 end; 1832 end;
1826 PreviousKeyword := Trim(Keyword); 1833 PreviousKeyword := Trim(Keyword);
1827 Insert(Keyword, Result, Run); 1834 Insert(Keyword, Result, Run);
1828 Inc(Run, Length(Keyword)); 1835 Inc(Run, Length(Keyword));
1829 Keyword := ''; 1836 Keyword := '';
1830 end; 1837 end;
1831 if (not InComment) and (not InBigComment) and (not InString) and (not InIdent) then begin 1838 if (not InComment) and (not InBigComment) and (not InString) and (not InIdent) then begin
1832 TestPair := Result[Run-1] + c; 1839 TestPair := Result[Run-1] + c;
1833 if (TestPair = ' ') or (TestPair = '( ') then begin 1840 if (TestPair = ' ') or (TestPair = '( ') then begin
1834 c := Result[Run-1]; 1841 c := Result[Run-1];
1835 Dec(Run); 1842 Dec(Run);
1836 end; 1843 end;
1837 if (TestPair = ' )') or (TestPair = ' ,') then 1844 if (TestPair = ' )') or (TestPair = ' ,') then
1838 Dec(Run); 1845 Dec(Run);
1839 end; 1846 end;
1840 Result[Run] := c; 1847 Result[Run] := c;
1841 Inc(Run); 1848 Inc(Run);
1842 end; 1849 end;
1843 1850
1844 end; 1851 end;
1845 1852
1846 // Cut overlength 1853 // Cut overlength
1847 SetLength(Result, Run-2); 1854 SetLength(Result, Run-2);
1848 end; 1855 end;
1849 1856
1850 1857
1851 1858
1852 { *** TDBObjectEditor } 1859 { *** TDBObjectEditor }
1853 1860
1854 constructor TDBObjectEditor.Create(AOwner: TComponent); 1861 constructor TDBObjectEditor.Create(AOwner: TComponent);
1855 begin 1862 begin
1856 inherited; 1863 inherited;
1857 // Do not set alClient via DFM! In conjunction with ExplicitXXX properties that 1864 // Do not set alClient via DFM! In conjunction with ExplicitXXX properties that
1858 // repeatedly breaks the GUI layout when you reload the project 1865 // repeatedly breaks the GUI layout when you reload the project
1859 Align := alClient; 1866 Align := alClient;
1860 InheritFont(Font); 1867 InheritFont(Font);
1861 ScaleControls(Screen.PixelsPerInch, FORMS_DPI); 1868 ScaleControls(Screen.PixelsPerInch, FORMS_DPI);
1862 end; 1869 end;
1863 1870
1864 destructor TDBObjectEditor.Destroy; 1871 destructor TDBObjectEditor.Destroy;
1865 begin 1872 begin
1866 inherited; 1873 inherited;
1867 end; 1874 end;
1868 1875
1869 procedure TDBObjectEditor.SetModified(Value: Boolean); 1876 procedure TDBObjectEditor.SetModified(Value: Boolean);
1870 begin 1877 begin
1871 FModified := Value; 1878 FModified := Value;
1872 end; 1879 end;
1873 1880
1874 procedure TDBObjectEditor.Init(Obj: TDBObject); 1881 procedure TDBObjectEditor.Init(Obj: TDBObject);
1875 var 1882 var
1876 editName: TWinControl; 1883 editName: TWinControl;
1877 SynMemo: TSynMemo; 1884 SynMemo: TSynMemo;
1878 popup: TPopupMenu; 1885 popup: TPopupMenu;
1879 Item: TMenuItem; 1886 Item: TMenuItem;
1880 begin 1887 begin
1881 Mainform.ShowStatusMsg('Initializing editor ...'); 1888 Mainform.ShowStatusMsg('Initializing editor ...');
1882 Mainform.LogSQL(Self.ClassName+'.Init, using object "'+Obj.Name+'"', lcDebug); 1889 Mainform.LogSQL(Self.ClassName+'.Init, using object "'+Obj.Name+'"', lcDebug);
1883 DBObject := TDBObject.Create(Obj.Connection); 1890 DBObject := TDBObject.Create(Obj.Connection);
1884 DBObject.Assign(Obj); 1891 DBObject.Assign(Obj);
1885 Mainform.UpdateEditorTab; 1892 Mainform.UpdateEditorTab;
1886 Screen.Cursor := crHourglass; 1893 Screen.Cursor := crHourglass;
1887 // Enable user to start typing immediately when creating a new object 1894 // Enable user to start typing immediately when creating a new object
1888 if DBObject.Name = '' then begin 1895 if DBObject.Name = '' then begin
1889 editName := FindComponent('editName') as TWinControl; 1896 editName := FindComponent('editName') as TWinControl;
1890 if Assigned(editName) and editName.CanFocus then 1897 if Assigned(editName) and editName.CanFocus then
1891 editName.SetFocus; 1898 editName.SetFocus;
1892 end; 1899 end;
1893 SynMemo := FindComponent('SynMemoBody') as TSynMemo; 1900 SynMemo := FindComponent('SynMemoBody') as TSynMemo;
1894 if Assigned(SynMemo) and (not Assigned(SynMemo.PopupMenu)) then begin 1901 if Assigned(SynMemo) and (not Assigned(SynMemo.PopupMenu)) then begin
1895 popup := TPopupMenu.Create(Self); 1902 popup := TPopupMenu.Create(Self);
1896 popup.Images := MainForm.ImageListMain; 1903 popup.Images := MainForm.ImageListMain;
1897 Item := TMenuItem.Create(popup); 1904 Item := TMenuItem.Create(popup);
1898 Item.Action := MainForm.actCopy; 1905 Item.Action := MainForm.actCopy;
1899 popup.Items.Add(Item); 1906 popup.Items.Add(Item);
1900 Item := TMenuItem.Create(popup); 1907 Item := TMenuItem.Create(popup);
1901 Item.Action := MainForm.actCut; 1908 Item.Action := MainForm.actCut;
1902 popup.Items.Add(Item); 1909 popup.Items.Add(Item);
1903 Item := TMenuItem.Create(popup); 1910 Item := TMenuItem.Create(popup);
1904 Item.Action := MainForm.actPaste; 1911 Item.Action := MainForm.actPaste;
1905 popup.Items.Add(Item); 1912 popup.Items.Add(Item);
1906 Item := TMenuItem.Create(popup); 1913 Item := TMenuItem.Create(popup);
1907 Item.Action := MainForm.actSelectAll; 1914 Item.Action := MainForm.actSelectAll;
1908 popup.Items.Add(Item); 1915 popup.Items.Add(Item);
1909 SynMemo.PopupMenu := popup; 1916 SynMemo.PopupMenu := popup;
1910 end; 1917 end;
1911 1918
1912 end; 1919 end;
1913 1920
1914 function TDBObjectEditor.DeInit: TModalResult; 1921 function TDBObjectEditor.DeInit: TModalResult;
1915 var 1922 var
1916 Msg, ObjType: String; 1923 Msg, ObjType: String;
1917 begin 1924 begin
1918 // Ask for saving modifications 1925 // Ask for saving modifications
1919 Result := mrOk; 1926 Result := mrOk;
1920 if Modified then begin 1927 if Modified then begin
1921 ObjType := LowerCase(DBObject.ObjType); 1928 ObjType := LowerCase(DBObject.ObjType);
1922 if DBObject.Name <> '' then 1929 if DBObject.Name <> '' then
1923 Msg := 'Save modified '+ObjType+' "'+DBObject.Name+'"?' 1930 Msg := 'Save modified '+ObjType+' "'+DBObject.Name+'"?'
1924 else 1931 else
1925 Msg := 'Save new '+ObjType+'?'; 1932 Msg := 'Save new '+ObjType+'?';
1926 Result := MessageDialog(Msg, mtConfirmation, [mbYes, mbNo, mbCancel]); 1933 Result := MessageDialog(Msg, mtConfirmation, [mbYes, mbNo, mbCancel]);
1927 case Result of 1934 case Result of
1928 mrYes: Result := ApplyModifications; 1935 mrYes: Result := ApplyModifications;
1929 mrNo: Modified := False; 1936 mrNo: Modified := False;
1930 end; 1937 end;
1931 end; 1938 end;
1932 end; 1939 end;
1933 1940
1934 1941
1935 function TDBObjectEditor.GetDefiners: TStringList; 1942 function TDBObjectEditor.GetDefiners: TStringList;
1936 function q(s: String): String; 1943 function q(s: String): String;
1937 begin 1944 begin
1938 Result := DBObject.Connection.QuoteIdent(s); 1945 Result := DBObject.Connection.QuoteIdent(s);
1939 end; 1946 end;
1940 begin 1947 begin
1941 // For populating combobox items 1948 // For populating combobox items
1942 if not Assigned(FDefiners) then begin 1949 if not Assigned(FDefiners) then begin
1943 try 1950 try
1944 FDefiners := DBObject.Connection.GetCol('SELECT CONCAT('+q('User')+', '+esc('@')+', '+q('Host')+') FROM '+ 1951 FDefiners := DBObject.Connection.GetCol('SELECT CONCAT('+q('User')+', '+esc('@')+', '+q('Host')+') FROM '+
1945 q('mysql')+'.'+q('user')+' WHERE '+q('User')+'!='+esc('')+' ORDER BY '+q('User')+', '+q('Host')); 1952 q('mysql')+'.'+q('user')+' WHERE '+q('User')+'!='+esc('')+' ORDER BY '+q('User')+', '+q('Host'));
1946 except on E:EDatabaseError do 1953 except on E:EDatabaseError do
1947 FDefiners := TStringList.Create; 1954 FDefiners := TStringList.Create;
1948 end; 1955 end;
1949 end; 1956 end;
1950 Result := FDefiners; 1957 Result := FDefiners;
1951 end; 1958 end;
1952 1959
1953 1960
1954 1961
1955 1962
1956 // Following code taken from OneInst.pas, http://assarbad.net/de/stuff/!import/nico.old/ 1963 // Following code taken from OneInst.pas, http://assarbad.net/de/stuff/!import/nico.old/
1957 // Slightly modified to better integrate that into our code, comments translated from german. 1964 // Slightly modified to better integrate that into our code, comments translated from german.
1958 1965
1959 // Fetch and separate command line parameters into strings 1966 // Fetch and separate command line parameters into strings
1960 function ParamBlobToStr(lpData: Pointer): TStringlist; 1967 function ParamBlobToStr(lpData: Pointer): TStringlist;
1961 var 1968 var
1962 pStr: PChar; 1969 pStr: PChar;
1963 begin 1970 begin
1964 Result := TStringlist.Create; 1971 Result := TStringlist.Create;
1965 pStr := lpData; 1972 pStr := lpData;
1966 while pStr[0] <> #0 do 1973 while pStr[0] <> #0 do
1967 begin 1974 begin
1968 Result.Add(string(pStr)); 1975 Result.Add(string(pStr));
1969 pStr := @pStr[lstrlen(pStr) + 1]; 1976 pStr := @pStr[lstrlen(pStr) + 1];
1970 end; 1977 end;
1971 end; 1978 end;
1972 1979
1973 // Pack current command line parameters 1980 // Pack current command line parameters
1974 function ParamStrToBlob(out cbData: DWORD): Pointer; 1981 function ParamStrToBlob(out cbData: DWORD): Pointer;
1975 var 1982 var
1976 Loop: Integer; 1983 Loop: Integer;
1977 pStr: PChar; 1984 pStr: PChar;
1978 begin 1985 begin
1979 for Loop := 1 to ParamCount do 1986 for Loop := 1 to ParamCount do
1980 cbData := cbData + DWORD(Length(ParamStr(Loop))*2 + 1); 1987 cbData := cbData + DWORD(Length(ParamStr(Loop))*2 + 1);
1981 cbData := cbData + 2; // include appending #0#0 1988 cbData := cbData + 2; // include appending #0#0
1982 Result := GetMemory(cbData); 1989 Result := GetMemory(cbData);
1983 ZeroMemory(Result, cbData); 1990 ZeroMemory(Result, cbData);
1984 pStr := Result; 1991 pStr := Result;
1985 for Loop := 1 to ParamCount do 1992 for Loop := 1 to ParamCount do
1986 begin 1993 begin
1987 lstrcpy(pStr, PChar(ParamStr(Loop))); 1994 lstrcpy(pStr, PChar(ParamStr(Loop)));
1988 pStr := @pStr[lstrlen(pStr) + 1]; 1995 pStr := @pStr[lstrlen(pStr) + 1];
1989 end; 1996 end;
1990 end; 1997 end;
1991 1998
1992 procedure HandleSecondInstance; 1999 procedure HandleSecondInstance;
1993 var 2000 var
1994 Run: DWORD; 2001 Run: DWORD;
1995 Now: DWORD; 2002 Now: DWORD;
1996 Msg: TMsg; 2003 Msg: TMsg;
1997 Wnd: HWND; 2004 Wnd: HWND;
1998 Dat: TCopyDataStruct; 2005 Dat: TCopyDataStruct;
1999 begin 2006 begin
2000 // MessageBox(0, 'already running', nil, MB_ICONINFORMATION); 2007 // MessageBox(0, 'already running', nil, MB_ICONINFORMATION);
2001 // Send a message to all main windows (HWND_BROADCAST) with the identical, 2008 // Send a message to all main windows (HWND_BROADCAST) with the identical,
2002 // previously registered message id. We should only get reply from 0 or 1 2009 // previously registered message id. We should only get reply from 0 or 1
2003 // instances. 2010 // instances.
2004 // (Broadcast should only be called with registered message ids!) 2011 // (Broadcast should only be called with registered message ids!)
2005 2012
2006 SendMessage(HWND_BROADCAST, SecondInstMsgId, GetCurrentThreadId, 0); 2013 SendMessage(HWND_BROADCAST, SecondInstMsgId, GetCurrentThreadId, 0);
2007 2014
2008 // Waiting for reply by first instance. For those of you which didn't knew: 2015 // Waiting for reply by first instance. For those of you which didn't knew:
2009 // Threads have message queues too ;o) 2016 // Threads have message queues too ;o)
2010 Wnd := 0; 2017 Wnd := 0;
2011 Run := GetTickCount; 2018 Run := GetTickCount;
2012 while True do 2019 while True do
2013 begin 2020 begin
2014 if PeekMessage(Msg, 0, SecondInstMsgId, SecondInstMsgId, PM_NOREMOVE) then 2021 if PeekMessage(Msg, 0, SecondInstMsgId, SecondInstMsgId, PM_NOREMOVE) then
2015 begin 2022 begin
2016 GetMessage(Msg, 0, SecondInstMsgId, SecondInstMsgId); 2023 GetMessage(Msg, 0, SecondInstMsgId, SecondInstMsgId);
2017 if Msg.message = SecondInstMsgId then 2024 if Msg.message = SecondInstMsgId then
2018 begin 2025 begin
2019 Wnd := Msg.wParam; 2026 Wnd := Msg.wParam;
2020 Break; 2027 Break;
2021 end; 2028 end;
2022 end; 2029 end;
2023 Now := GetTickCount; 2030 Now := GetTickCount;
2024 if Now < Run then 2031 if Now < Run then
2025 Run := Now; // Avoid overflow, each 48 days. 2032 Run := Now; // Avoid overflow, each 48 days.
2026 if Now - Run > 5000 then 2033 if Now - Run > 5000 then
2027 Break; 2034 Break;
2028 end; 2035 end;
2029 2036
2030 if (Wnd <> 0) and IsWindow(Wnd) then 2037 if (Wnd <> 0) and IsWindow(Wnd) then
2031 begin 2038 begin
2032 // As a reply we got a handle to which we now send current parameters 2039 // As a reply we got a handle to which we now send current parameters
2033 Dat.dwData := SecondInstMsgId; 2040 Dat.dwData := SecondInstMsgId;
2034 Dat.lpData := ParamStrToBlob(Dat.cbData); 2041 Dat.lpData := ParamStrToBlob(Dat.cbData);
2035 SendMessage(Wnd, WM_COPYDATA, 0, LPARAM(@Dat)); 2042 SendMessage(Wnd, WM_COPYDATA, 0, LPARAM(@Dat));
2036 FreeMemory(Dat.lpData); 2043 FreeMemory(Dat.lpData);
2037 2044
2038 // Bring first instance to front 2045 // Bring first instance to front
2039 if not IsWindowVisible(Wnd) then 2046 if not IsWindowVisible(Wnd) then
2040 ShowWindow(Wnd, SW_RESTORE); 2047 ShowWindow(Wnd, SW_RESTORE);
2041 BringWindowToTop(Wnd); 2048 BringWindowToTop(Wnd);
2042 SetForegroundWindow(Wnd); 2049 SetForegroundWindow(Wnd);
2043 end; 2050 end;
2044 end; 2051 end;
2045 2052
2046 function CheckForSecondInstance: Boolean; 2053 function CheckForSecondInstance: Boolean;
2047 var 2054 var
2048 Loop: Integer; 2055 Loop: Integer;
2049 MutexName: PChar; 2056 MutexName: PChar;
2050 begin 2057 begin
2051 // Try to create a system wide named kernel object (mutex). And check if that 2058 // Try to create a system wide named kernel object (mutex). And check if that
2052 // already exists. 2059 // already exists.
2053 // The name of such a mutex must not be longer than MAX_PATH (260) chars and 2060 // The name of such a mutex must not be longer than MAX_PATH (260) chars and
2054 // can contain all chars but not '\' 2061 // can contain all chars but not '\'
2055 2062
2056 Result := False; 2063 Result := False;
2057 MutexName := PChar(APPNAME); 2064 MutexName := PChar(APPNAME);
2058 for Loop := lstrlen(MutexName) to MAX_PATH - 1 do 2065 for Loop := lstrlen(MutexName) to MAX_PATH - 1 do
2059 begin 2066 begin
2060 MutexHandle := CreateMutex(nil, False, MutexName); 2067 MutexHandle := CreateMutex(nil, False, MutexName);
2061 if (MutexHandle = 0) and (GetLastError = INVALID_HANDLE_VALUE) then 2068 if (MutexHandle = 0) and (GetLastError = INVALID_HANDLE_VALUE) then
2062 // Looks like there is already a mutex using this name 2069 // Looks like there is already a mutex using this name
2063 // Try to solve that by appending an underscore 2070 // Try to solve that by appending an underscore
2064 lstrcat(MutexName, '_') 2071 lstrcat(MutexName, '_')
2065 else 2072 else
2066 // At least no naming conflict 2073 // At least no naming conflict
2067 Break; 2074 Break;
2068 end; 2075 end;
2069 2076
2070 case GetLastError of 2077 case GetLastError of
2071 0: begin 2078 0: begin
2072 // We created the mutex, so this is the first instance 2079 // We created the mutex, so this is the first instance
2073 end; 2080 end;
2074 ERROR_ALREADY_EXISTS: 2081 ERROR_ALREADY_EXISTS:
2075 begin 2082 begin
2076 // There is already one instance 2083 // There is already one instance
2077 try 2084 try
2078 HandleSecondInstance; 2085 HandleSecondInstance;
2079 finally 2086 finally
2080 // Terminating is done in .dpr file, before Application.Initialize 2087 // Terminating is done in .dpr file, before Application.Initialize
2081 Result := True; 2088 Result := True;
2082 end; 2089 end;
2083 end; 2090 end;
2084 else 2091 else
2085 // No clue why we should get here. Oh, maybe Microsoft has changed rules, again. 2092 // No clue why we should get here. Oh, maybe Microsoft has changed rules, again.
2086 // However, we return false and let the application start 2093 // However, we return false and let the application start
2087 end; 2094 end;
2088 end; 2095 end;
2089 2096
2090 2097
2091 function GetParentFormOrFrame(Comp: TWinControl): TWinControl; 2098 function GetParentFormOrFrame(Comp: TWinControl): TWinControl;
2092 begin 2099 begin
2093 Result := Comp; 2100 Result := Comp;
2094 while True do begin 2101 while True do begin
2095 Result := Result.Parent; 2102 Result := Result.Parent;
2096 // On a windows shutdown, GetParentForm() seems sporadically unable to find the owner form 2103 // On a windows shutdown, GetParentForm() seems sporadically unable to find the owner form
2097 // In that case we would cause an exception when accessing it. Emergency break in that case. 2104 // In that case we would cause an exception when accessing it. Emergency break in that case.
2098 // See issue #1462 2105 // See issue #1462
2099 if (not Assigned(Result)) or (Result is TCustomForm) or (Result is TFrame) then 2106 if (not Assigned(Result)) or (Result is TCustomForm) or (Result is TFrame) then
2100 break; 2107 break;
2101 end; 2108 end;
2102 end; 2109 end;
2103 2110
2104 2111
2105 function GetIndexIcon(IndexType: String): Integer; 2112 function GetIndexIcon(IndexType: String): Integer;
2106 begin 2113 begin
2107 // Detect key icon index for specified index 2114 // Detect key icon index for specified index
2108 if IndexType = PKEY then Result := ICONINDEX_PRIMARYKEY 2115 if IndexType = PKEY then Result := ICONINDEX_PRIMARYKEY
2109 else if IndexType = KEY then Result := ICONINDEX_INDEXKEY 2116 else if IndexType = KEY then Result := ICONINDEX_INDEXKEY
2110 else if IndexType = UKEY then Result := ICONINDEX_UNIQUEKEY 2117 else if IndexType = UKEY then Result := ICONINDEX_UNIQUEKEY
2111 else if IndexType = FKEY then Result := ICONINDEX_FULLTEXTKEY 2118 else if IndexType = FKEY then Result := ICONINDEX_FULLTEXTKEY
2112 else if IndexType = SKEY then Result := ICONINDEX_SPATIALKEY 2119 else if IndexType = SKEY then Result := ICONINDEX_SPATIALKEY
2113 else Result := -1; 2120 else Result := -1;
2114 end; 2121 end;
2115 2122
2116 2123
2117 function KeyPressed(Code: Integer): Boolean; 2124 function KeyPressed(Code: Integer): Boolean;
2118 var 2125 var
2119 State: TKeyboardState; 2126 State: TKeyboardState;
2120 begin 2127 begin
2121 // Checks whether a key is pressed, defined by virtual key code 2128 // Checks whether a key is pressed, defined by virtual key code
2122 GetKeyboardState(State); 2129 GetKeyboardState(State);
2123 Result := (State[Code] and 128) <> 0; 2130 Result := (State[Code] and 128) <> 0;
2124 end; 2131 end;
2125 2132
2126 2133
2127 function GeneratePassword(Len: Integer): String; 2134 function GeneratePassword(Len: Integer): String;
2128 var 2135 var
2129 i: Integer; 2136 i: Integer;
2130 CharTable: String; 2137 CharTable: String;
2131 const 2138 const
2132 Consos = 'bcdfghjklmnpqrstvwxyzBCDFGHJKLMNPQRSTVWXYZ'; 2139 Consos = 'bcdfghjklmnpqrstvwxyzBCDFGHJKLMNPQRSTVWXYZ';
2133 Vocals = 'aeiouAEIOU'; 2140 Vocals = 'aeiouAEIOU';
2134 Numbers = '123456789'; 2141 Numbers = '123456789';
2135 begin 2142 begin
2136 // Create a random, mnemonic password 2143 // Create a random, mnemonic password
2137 SetLength(Result, Len); 2144 SetLength(Result, Len);
2138 for i:=1 to Len do begin 2145 for i:=1 to Len do begin
2139 if Random(4) = 1 then 2146 if Random(4) = 1 then
2140 CharTable := Numbers 2147 CharTable := Numbers
2141 else if i mod 2 = 0 then 2148 else if i mod 2 = 0 then
2142 CharTable := Vocals 2149 CharTable := Vocals
2143 else 2150 else
2144 CharTable := Consos; 2151 CharTable := Consos;
2145 Result[i] := CharTable[Random(Length(CharTable)-1)+1]; 2152 Result[i] := CharTable[Random(Length(CharTable)-1)+1];
2146 end; 2153 end;
2147 end; 2154 end;
2148 2155
2149 2156
2150 procedure InvalidateVT(VT: TVirtualStringTree; RefreshTag: Integer; ImmediateRepaint: Boolean); 2157 procedure InvalidateVT(VT: TVirtualStringTree; RefreshTag: Integer; ImmediateRepaint: Boolean);
2151 begin 2158 begin
2152 // Avoid AVs in OnDestroy events 2159 // Avoid AVs in OnDestroy events
2153 if not Assigned(VT) then 2160 if not Assigned(VT) then
2154 Exit; 2161 Exit;
2155 VT.Tag := RefreshTag; 2162 VT.Tag := RefreshTag;
2156 if ImmediateRepaint then 2163 if ImmediateRepaint then
2157 VT.Repaint 2164 VT.Repaint
2158 else 2165 else
2159 VT.Invalidate; 2166 VT.Invalidate;
2160 end; 2167 end;
2161 2168
2162 2169
2163 procedure ImportSettings(Filename: String); 2170 procedure ImportSettings(Filename: String);
2164 var 2171 var
2165 Content, Name, Value, KeyPath: String; 2172 Content, Name, Value, KeyPath: String;
2166 Lines, Segments: TStringList; 2173 Lines, Segments: TStringList;
2167 i: Integer; 2174 i: Integer;
2168 DataType: TRegDataType; 2175 DataType: TRegDataType;
2169 begin 2176 begin
2170 // Load registry settings from file 2177 // Load registry settings from file
2171 Content := ReadTextfile(FileName, nil); 2178 Content := ReadTextfile(FileName, nil);
2172 Lines := Explode(CRLF, Content); 2179 Lines := Explode(CRLF, Content);
2173 for i:=0 to Lines.Count-1 do begin 2180 for i:=0 to Lines.Count-1 do begin
2174 // Each line has 3 segments: reg path | data type | value. Continue if explode finds less or more than 3. 2181 // Each line has 3 segments: reg path | data type | value. Continue if explode finds less or more than 3.
2175 Segments := Explode(DELIMITER, Lines[i]); 2182 Segments := Explode(DELIMITER, Lines[i]);
2176 if Segments.Count <> 3 then 2183 if Segments.Count <> 3 then
2177 continue; 2184 continue;
2178 KeyPath := RegPath + ExtractFilePath(Segments[0]); 2185 KeyPath := RegPath + ExtractFilePath(Segments[0]);
2179 Name := ExtractFileName(Segments[0]); 2186 Name := ExtractFileName(Segments[0]);
2180 DataType := TRegDataType(StrToInt(Segments[1])); 2187 DataType := TRegDataType(StrToInt(Segments[1]));
2181 MainReg.OpenKey(KeyPath, True); 2188 MainReg.OpenKey(KeyPath, True);
2182 if MainReg.ValueExists(Name) then 2189 if MainReg.ValueExists(Name) then
2183 Continue; // Don't touch value if already there 2190 Continue; // Don't touch value if already there
2184 Value := ''; 2191 Value := '';
2185 if Segments.Count >= 3 then 2192 if Segments.Count >= 3 then
2186 Value := Segments[2]; 2193 Value := Segments[2];
2187 case DataType of 2194 case DataType of
2188 rdString: begin 2195 rdString: begin
2189 Value := StringReplace(Value, CHR13REPLACEMENT, #13, [rfReplaceAll]); 2196 Value := StringReplace(Value, CHR13REPLACEMENT, #13, [rfReplaceAll]);
2190 Value := StringReplace(Value, CHR10REPLACEMENT, #10, [rfReplaceAll]); 2197 Value := StringReplace(Value, CHR10REPLACEMENT, #10, [rfReplaceAll]);
2191 MainReg.WriteString(Name, Value); 2198 MainReg.WriteString(Name, Value);
2192 end; 2199 end;
2193 rdInteger: 2200 rdInteger:
2194 MainReg.WriteInteger(Name, MakeInt(Value)); 2201 MainReg.WriteInteger(Name, MakeInt(Value));
2195 rdBinary, rdUnknown, rdExpandString: 2202 rdBinary, rdUnknown, rdExpandString:
2196 ErrorDialog(Name+' has an unsupported data type.'); 2203 ErrorDialog(Name+' has an unsupported data type.');
2197 end; 2204 end;
2198 Segments.Free; 2205 Segments.Free;
2199 end; 2206 end;
2200 Lines.Free; 2207 Lines.Free;
2201 end; 2208 end;
2202 2209
2203 2210
2204 procedure ExportSettings(Filename: String); 2211 procedure ExportSettings(Filename: String);
2205 var 2212 var
2206 Content, Value: String; 2213 Content, Value: String;
2207 DataType: TRegDataType; 2214 DataType: TRegDataType;
2208 2215
2209 procedure ReadKeyToContent(Path: String); 2216 procedure ReadKeyToContent(Path: String);
2210 var 2217 var
2211 Names: TStringList; 2218 Names: TStringList;
2212 i: Integer; 2219 i: Integer;
2213 SubPath: String; 2220 SubPath: String;
2214 begin 2221 begin
2215 // Recursively read values in keys and their subkeys into "content" variable 2222 // Recursively read values in keys and their subkeys into "content" variable
2216 MainReg.OpenKey(Path, True); 2223 MainReg.OpenKey(Path, True);
2217 SubPath := Copy(Path, Length(RegPath)+1, MaxInt); 2224 SubPath := Copy(Path, Length(RegPath)+1, MaxInt);
2218 Names := TStringList.Create; 2225 Names := TStringList.Create;
2219 MainReg.GetValueNames(Names); 2226 MainReg.GetValueNames(Names);
2220 for i:=0 to Names.Count-1 do begin 2227 for i:=0 to Names.Count-1 do begin
2221 DataType := MainReg.GetDataType(Names[i]); 2228 DataType := MainReg.GetDataType(Names[i]);
2222 Content := Content + 2229 Content := Content +
2223 SubPath + Names[i] + DELIMITER + 2230 SubPath + Names[i] + DELIMITER +
2224 IntToStr(Integer(DataType)) + DELIMITER; 2231 IntToStr(Integer(DataType)) + DELIMITER;
2225 case DataType of 2232 case DataType of
2226 rdString: begin 2233 rdString: begin
2227 Value := MainReg.ReadString(Names[i]); 2234 Value := MainReg.ReadString(Names[i]);
2228 Value := StringReplace(Value, #13, CHR13REPLACEMENT, [rfReplaceAll]); 2235 Value := StringReplace(Value, #13, CHR13REPLACEMENT, [rfReplaceAll]);
2229 Value := StringReplace(Value, #10, CHR10REPLACEMENT, [rfReplaceAll]); 2236 Value := StringReplace(Value, #10, CHR10REPLACEMENT, [rfReplaceAll]);
2230 end; 2237 end;
2231 rdInteger: 2238 rdInteger:
2232 Value := IntToStr(MainReg.ReadInteger(Names[i])); 2239 Value := IntToStr(MainReg.ReadInteger(Names[i]));
2233 rdBinary, rdUnknown, rdExpandString: 2240 rdBinary, rdUnknown, rdExpandString:
2234 ErrorDialog(Names[i]+' has an unsupported data type.'); 2241 ErrorDialog(Names[i]+' has an unsupported data type.');
2235 end; 2242 end;
2236 Content := Content + Value + CRLF; 2243 Content := Content + Value + CRLF;
2237 end; 2244 end;
2238 Names.Clear; 2245 Names.Clear;
2239 MainReg.GetKeyNames(Names); 2246 MainReg.GetKeyNames(Names);
2240 for i:=0 to Names.Count-1 do 2247 for i:=0 to Names.Count-1 do
2241 ReadKeyToContent(Path + Names[i] + '\'); 2248 ReadKeyToContent(Path + Names[i] + '\');
2242 Names.Free; 2249 Names.Free;
2243 end; 2250 end;
2244 2251
2245 begin 2252 begin
2246 // Save registry settings to file 2253 // Save registry settings to file
2247 Content := ''; 2254 Content := '';
2248 ReadKeyToContent(RegPath); 2255 ReadKeyToContent(RegPath);
2249 SaveUnicodeFile(FileName, Content); 2256 SaveUnicodeFile(FileName, Content);
2250 end; 2257 end;
2251 2258
2252 2259
2253 procedure HandlePortableSettings(StartupMode: Boolean); 2260 procedure HandlePortableSettings(StartupMode: Boolean);
2254 var 2261 var
2255 FileName: String; 2262 FileName: String;
2256 AllKeys: TStringList; 2263 AllKeys: TStringList;
2257 i: Integer; 2264 i: Integer;
2258 Proc: TProcessEntry32; 2265 Proc: TProcessEntry32;
2259 ProcRuns: Boolean; 2266 ProcRuns: Boolean;
2260 SnapShot: THandle; 2267 SnapShot: THandle;
2261 rx: TRegExpr; 2268 rx: TRegExpr;
2262 begin 2269 begin
2263 // Export registry keys and values into textfile, for portable reasons 2270 // Export registry keys and values into textfile, for portable reasons
2264 2271
2265 // Use filename from command line. If not given, use file in directory of executable. 2272 // Use filename from command line. If not given, use file in directory of executable.
2266 rx := TRegExpr.Create; 2273 rx := TRegExpr.Create;
2267 rx.Expression := '^\-\-?psettings\=(.+)$'; 2274 rx.Expression := '^\-\-?psettings\=(.+)$';
2268 for i:=1 to ParamCount do begin 2275 for i:=1 to ParamCount do begin
2269 if rx.Exec(ParamStr(i)) then begin 2276 if rx.Exec(ParamStr(i)) then begin
2270 Filename := rx.Match[1]; 2277 Filename := rx.Match[1];
2271 break; 2278 break;
2272 end; 2279 end;
2273 end; 2280 end;
2274 if Filename = '' then 2281 if Filename = '' then
2275 Filename := ExtractFilePath(ParamStr(0)) + 'portable_settings.txt'; 2282 Filename := ExtractFilePath(ParamStr(0)) + 'portable_settings.txt';
2276 if not FileExists(FileName) then 2283 if not FileExists(FileName) then
2277 Exit; 2284 Exit;
2278 2285
2279 // Open the right key 2286 // Open the right key
2280 if StartupMode then begin 2287 if StartupMode then begin
2281 RegPath := '\Software\' + APPNAME + ' Portable '+IntToStr(GetCurrentProcessId)+'\'; 2288 RegPath := '\Software\' + APPNAME + ' Portable '+IntToStr(GetCurrentProcessId)+'\';
2282 PortableMode := True; 2289 PortableMode := True;
2283 end else begin 2290 end else begin
2284 // Do not work like a portable on exit, if at application start we didn't either 2291 // Do not work like a portable on exit, if at application start we didn't either
2285 if not PortableMode then 2292 if not PortableMode then
2286 Exit; 2293 Exit;
2287 end; 2294 end;
2288 2295
2289 Screen.Cursor := crHourGlass; 2296 Screen.Cursor := crHourGlass;
2290 try 2297 try
2291 // Both ImportSettings and ExportSettings rely on RegPath pointing to the right reg key 2298 // Both ImportSettings and ExportSettings rely on RegPath pointing to the right reg key
2292 if StartupMode then begin 2299 if StartupMode then begin
2293 ImportSettings(Filename); 2300 ImportSettings(Filename);
2294 end else begin 2301 end else begin
2295 // Application closes 2302 // Application closes
2296 ExportSettings(Filename); 2303 ExportSettings(Filename);
2297 MainReg.CloseKey; 2304 MainReg.CloseKey;
2298 MainReg.DeleteKey(RegPath); 2305 MainReg.DeleteKey(RegPath);
2299 2306
2300 // Remove dead keys from instances which didn't close clean, e.g. because of an AV 2307 // Remove dead keys from instances which didn't close clean, e.g. because of an AV
2301 SnapShot := CreateToolhelp32Snapshot(TH32CS_SnapProcess, 0); 2308 SnapShot := CreateToolhelp32Snapshot(TH32CS_SnapProcess, 0);
2302 Proc.dwSize := Sizeof(Proc); 2309 Proc.dwSize := Sizeof(Proc);
2303 MainReg.OpenKeyReadOnly('\Software\'); 2310 MainReg.OpenKeyReadOnly('\Software\');
2304 AllKeys := TStringList.Create; 2311 AllKeys := TStringList.Create;
2305 MainReg.GetKeyNames(AllKeys); 2312 MainReg.GetKeyNames(AllKeys);
2306 rx.Expression := '^' + QuoteRegExprMetaChars(APPNAME) + ' Portable (\d+)$'; 2313 rx.Expression := '^' + QuoteRegExprMetaChars(APPNAME) + ' Portable (\d+)$';
2307 for i:=0 to AllKeys.Count-1 do begin 2314 for i:=0 to AllKeys.Count-1 do begin
2308 if not rx.Exec(AllKeys[i]) then 2315 if not rx.Exec(AllKeys[i]) then
2309 Continue; 2316 Continue;
2310 ProcRuns := False; 2317 ProcRuns := False;
2311 if Process32First(SnapShot, Proc) then while True do begin 2318 if Process32First(SnapShot, Proc) then while True do begin
2312 ProcRuns := rx.Match[1] = IntToStr(Proc.th32ProcessID); 2319 ProcRuns := rx.Match[1] = IntToStr(Proc.th32ProcessID);
2313 if ProcRuns or (not Process32Next(SnapShot, Proc)) then 2320 if ProcRuns or (not Process32Next(SnapShot, Proc)) then
2314 break; 2321 break;
2315 end; 2322 end;
2316 if not ProcRuns then 2323 if not ProcRuns then
2317 MainReg.DeleteKey(AllKeys[i]); 2324 MainReg.DeleteKey(AllKeys[i]);
2318 end; 2325 end;
2319 MainReg.CloseKey; 2326 MainReg.CloseKey;
2320 CloseHandle(SnapShot); 2327 CloseHandle(SnapShot);
2321 AllKeys.Free; 2328 AllKeys.Free;
2322 rx.Free; 2329 rx.Free;
2323 end; 2330 end;
2324 except 2331 except
2325 On E:Exception do 2332 On E:Exception do
2326 ErrorDialog(E.Message); 2333 ErrorDialog(E.Message);
2327 end; 2334 end;
2328 Screen.Cursor := crDefault; 2335 Screen.Cursor := crDefault;
2329 2336
2330 end; 2337 end;
2331 2338
2332 2339
2333 function CharAtPos(Str: String; Pos: Integer): Char; 2340 function CharAtPos(Str: String; Pos: Integer): Char;
2334 begin 2341 begin
2335 // Access char in string without causing access violation 2342 // Access char in string without causing access violation
2336 if Length(Str) < Pos then 2343 if Length(Str) < Pos then
2337 Result := #0 2344 Result := #0
2338 else 2345 else
2339 Result := Str[Pos]; 2346 Result := Str[Pos];
2340 end; 2347 end;
2341 2348
2342 2349
2343 function CompareAnyNode(Text1, Text2: String): Integer; 2350 function CompareAnyNode(Text1, Text2: String): Integer;
2344 var 2351 var
2345 Number1, Number2 : Extended; 2352 Number1, Number2 : Extended;
2346 a1, a2, b1, b2: Char; 2353 a1, a2, b1, b2: Char;
2347 NumberMode: Boolean; 2354 NumberMode: Boolean;
2348 const 2355 const
2349 Numbers = ['0'..'9']; 2356 Numbers = ['0'..'9'];
2350 begin 2357 begin
2351 Result := 0; 2358 Result := 0;
2352 // Apply different comparisons for numbers and text 2359 // Apply different comparisons for numbers and text
2353 a1 := CharAtPos(Text1, 1); 2360 a1 := CharAtPos(Text1, 1);
2354 a2 := CharAtPos(Text1, 2); 2361 a2 := CharAtPos(Text1, 2);
2355 b1 := CharAtPos(Text2, 1); 2362 b1 := CharAtPos(Text2, 1);
2356 b2 := CharAtPos(Text2, 2); 2363 b2 := CharAtPos(Text2, 2);
2357 NumberMode := ((a1='-') and (CharInSet(a2, Numbers)) or CharInSet(a1, Numbers)) 2364 NumberMode := ((a1='-') and (CharInSet(a2, Numbers)) or CharInSet(a1, Numbers))
2358 and ((b1='-') and (CharInSet(b2, Numbers)) or CharInSet(b1, Numbers)); 2365 and ((b1='-') and (CharInSet(b2, Numbers)) or CharInSet(b1, Numbers));
2359 if NumberMode then begin 2366 if NumberMode then begin
2360 // Assuming numeric values 2367 // Assuming numeric values
2361 Number1 := MakeFloat(Text1); 2368 Number1 := MakeFloat(Text1);
2362 Number2 := MakeFloat(Text2); 2369 Number2 := MakeFloat(Text2);
2363 if Number1 > Number2 then 2370 if Number1 > Number2 then
2364 Result := 1 2371 Result := 1
2365 else if Number1 = Number2 then 2372 else if Number1 = Number2 then
2366 Result := 0 2373 Result := 0
2367 else if Number1 < Number2 then 2374 else if Number1 < Number2 then
2368 Result := -1; 2375 Result := -1;
2369 end; 2376 end;
2370 if (not NumberMode) or (Result=0) then begin 2377 if (not NumberMode) or (Result=0) then begin
2371 // Compare Strings 2378 // Compare Strings
2372 Result := CompareText(Text1, Text2); 2379 Result := CompareText(Text1, Text2);
2373 end; 2380 end;
2374 end; 2381 end;
2375 2382
2376 2383
2377 function StringListCompareAnythingAsc(List: TStringList; Index1, Index2: Integer): Integer; 2384 function StringListCompareAnythingAsc(List: TStringList; Index1, Index2: Integer): Integer;
2378 begin 2385 begin
2379 // Sort TStringList items, containing numbers or strings, ascending 2386 // Sort TStringList items, containing numbers or strings, ascending
2380 Result := CompareAnyNode(List[Index1], List[Index2]); 2387 Result := CompareAnyNode(List[Index1], List[Index2]);
2381 end; 2388 end;
2382 2389
2383 2390
2384 function StringListCompareAnythingDesc(List: TStringList; Index1, Index2: Integer): Integer; 2391 function StringListCompareAnythingDesc(List: TStringList; Index1, Index2: Integer): Integer;
2385 begin 2392 begin
2386 // Sort TStringList items, containing numbers or strings, descending 2393 // Sort TStringList items, containing numbers or strings, descending
2387 Result := CompareAnyNode(List[Index2], List[Index1]); 2394 Result := CompareAnyNode(List[Index2], List[Index1]);
2388 end; 2395 end;
2389 2396
2390 2397
2391 function GetColumnDefaultType(var Text: String): TColumnDefaultType; 2398 function GetColumnDefaultType(var Text: String): TColumnDefaultType;
2392 begin 2399 begin
2393 Result := TColumnDefaultType(MakeInt(Copy(Text, 1, 1))); 2400 Result := TColumnDefaultType(MakeInt(Copy(Text, 1, 1)));
2394 Text := Copy(Text, 2, Length(Text)-1); 2401 Text := Copy(Text, 2, Length(Text)-1);
2395 end; 2402 end;
2396 2403
2397 2404
2398 function GetColumnDefaultClause(DefaultType: TColumnDefaultType; Text: String): String; 2405 function GetColumnDefaultClause(DefaultType: TColumnDefaultType; Text: String): String;
2399 begin 2406 begin
2400 case DefaultType of 2407 case DefaultType of
2401 cdtNothing: Result := ''; 2408 cdtNothing: Result := '';
2402 cdtText: Result := 'DEFAULT '+esc(Text); 2409 cdtText: Result := 'DEFAULT '+esc(Text);
2403 cdtTextUpdateTS: Result := 'DEFAULT '+esc(Text)+' ON UPDATE CURRENT_TIMESTAMP'; 2410 cdtTextUpdateTS: Result := 'DEFAULT '+esc(Text)+' ON UPDATE CURRENT_TIMESTAMP';
2404 cdtNull: Result := 'DEFAULT NULL'; 2411 cdtNull: Result := 'DEFAULT NULL';
2405 cdtNullUpdateTS: Result := 'DEFAULT NULL ON UPDATE CURRENT_TIMESTAMP'; 2412 cdtNullUpdateTS: Result := 'DEFAULT NULL ON UPDATE CURRENT_TIMESTAMP';
2406 cdtCurTS: Result := 'DEFAULT CURRENT_TIMESTAMP'; 2413 cdtCurTS: Result := 'DEFAULT CURRENT_TIMESTAMP';
2407 cdtCurTSUpdateTS: Result := 'DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP'; 2414 cdtCurTSUpdateTS: Result := 'DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP';
2408 cdtAutoInc: Result := 'AUTO_INCREMENT'; 2415 cdtAutoInc: Result := 'AUTO_INCREMENT';
2409 end; 2416 end;
2410 end; 2417 end;
2411 2418
2412 2419
2413 {** 2420 {**
2414 Return compile date/time from passed .exe name 2421 Return compile date/time from passed .exe name
2415 Code taken and modified from Michael Puff 2422 Code taken and modified from Michael Puff
2416 http://www.michael-puff.de/Programmierung/Delphi/Code-Snippets/GetImageLinkTimeStamp.shtml 2423 http://www.michael-puff.de/Programmierung/Delphi/Code-Snippets/GetImageLinkTimeStamp.shtml
2417 } 2424 }
2418 function GetImageLinkTimeStamp(const FileName: string): TDateTime; 2425 function GetImageLinkTimeStamp(const FileName: string): TDateTime;
2419 const 2426 const
2420 INVALID_SET_FILE_POINTER = DWORD(-1); 2427 INVALID_SET_FILE_POINTER = DWORD(-1);
2421 BorlandMagicTimeStamp = $2A425E19; // Delphi 4-6 (and above?) 2428 BorlandMagicTimeStamp = $2A425E19; // Delphi 4-6 (and above?)
2422 FileTime1970: TFileTime = (dwLowDateTime:$D53E8000; dwHighDateTime:$019DB1DE); 2429 FileTime1970: TFileTime = (dwLowDateTime:$D53E8000; dwHighDateTime:$019DB1DE);
2423 type 2430 type
2424 PImageSectionHeaders = ^TImageSectionHeaders; 2431 PImageSectionHeaders = ^TImageSectionHeaders;
2425 TImageSectionHeaders = array [Word] of TImageSectionHeader; 2432 TImageSectionHeaders = array [Word] of TImageSectionHeader;
2426 type 2433 type
2427 PImageResourceDirectory = ^TImageResourceDirectory; 2434 PImageResourceDirectory = ^TImageResourceDirectory;
2428 TImageResourceDirectory = packed record 2435 TImageResourceDirectory = packed record
2429 Characteristics: DWORD; 2436 Characteristics: DWORD;
2430 TimeDateStamp: DWORD; 2437 TimeDateStamp: DWORD;
2431 MajorVersion: Word; 2438 MajorVersion: Word;
2432 MinorVersion: Word; 2439 MinorVersion: Word;
2433 NumberOfNamedEntries: Word; 2440 NumberOfNamedEntries: Word;
2434 NumberOfIdEntries: Word; 2441 NumberOfIdEntries: Word;
2435 end; 2442 end;
2436 var 2443 var
2437 FileHandle: THandle; 2444 FileHandle: THandle;
2438 BytesRead: DWORD; 2445 BytesRead: DWORD;
2439 ImageDosHeader: TImageDosHeader; 2446 ImageDosHeader: TImageDosHeader;
2440 ImageNtHeaders: TImageNtHeaders; 2447 ImageNtHeaders: TImageNtHeaders;
2441 SectionHeaders: PImageSectionHeaders; 2448 SectionHeaders: PImageSectionHeaders;
2442 Section: Word; 2449 Section: Word;
2443 ResDirRVA: DWORD; 2450 ResDirRVA: DWORD;
2444 ResDirSize: DWORD; 2451 ResDirSize: DWORD;
2445 ResDirRaw: DWORD; 2452 ResDirRaw: DWORD;
2446 ResDirTable: TImageResourceDirectory; 2453 ResDirTable: TImageResourceDirectory;
2447 FileTime: TFileTime; 2454 FileTime: TFileTime;
2448 TimeStamp: DWord; 2455 TimeStamp: DWord;
2449 begin 2456 begin
2450 TimeStamp := 0; 2457 TimeStamp := 0;
2451 Result := 0; 2458 Result := 0;
2452 // Open file for read access 2459 // Open file for read access
2453 FileHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0); 2460 FileHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
2454 if (FileHandle <> INVALID_HANDLE_VALUE) then try 2461 if (FileHandle <> INVALID_HANDLE_VALUE) then try
2455 // Read MS-DOS header to get the offset of the PE32 header 2462 // Read MS-DOS header to get the offset of the PE32 header
2456 // (not required on WinNT based systems - but mostly available) 2463 // (not required on WinNT based systems - but mostly available)
2457 if not ReadFile(FileHandle, ImageDosHeader, SizeOf(TImageDosHeader), 2464 if not ReadFile(FileHandle, ImageDosHeader, SizeOf(TImageDosHeader),
2458 BytesRead, nil) or (BytesRead <> SizeOf(TImageDosHeader)) or 2465 BytesRead, nil) or (BytesRead <> SizeOf(TImageDosHeader)) or
2459 (ImageDosHeader.e_magic <> IMAGE_DOS_SIGNATURE) then begin 2466 (ImageDosHeader.e_magic <> IMAGE_DOS_SIGNATURE) then begin
2460 ImageDosHeader._lfanew := 0; 2467 ImageDosHeader._lfanew := 0;
2461 end; 2468 end;
2462 // Read PE32 header (including optional header 2469 // Read PE32 header (including optional header
2463 if (SetFilePointer(FileHandle, ImageDosHeader._lfanew, nil, FILE_BEGIN) = INVALID_SET_FILE_POINTER) then 2470 if (SetFilePointer(FileHandle, ImageDosHeader._lfanew, nil, FILE_BEGIN) = INVALID_SET_FILE_POINTER) then
2464 Exit; 2471 Exit;
2465 if not(ReadFile(FileHandle, ImageNtHeaders, SizeOf(TImageNtHeaders), BytesRead, nil) and (BytesRead = SizeOf(TImageNtHeaders))) then 2472 if not(ReadFile(FileHandle, ImageNtHeaders, SizeOf(TImageNtHeaders), BytesRead, nil) and (BytesRead = SizeOf(TImageNtHeaders))) then
2466 Exit; 2473 Exit;
2467 // Validate PE32 image header 2474 // Validate PE32 image header
2468 if (ImageNtHeaders.Signature <> IMAGE_NT_SIGNATURE) then 2475 if (ImageNtHeaders.Signature <> IMAGE_NT_SIGNATURE) then
2469 Exit; 2476 Exit;
2470 // Seconds since 1970 (UTC) 2477 // Seconds since 1970 (UTC)
2471 TimeStamp := ImageNtHeaders.FileHeader.TimeDateStamp; 2478 TimeStamp := ImageNtHeaders.FileHeader.TimeDateStamp;
2472 2479
2473 // Check for Borland's magic value for the link time stamp 2480 // Check for Borland's magic value for the link time stamp
2474 // (we take the time stamp from the resource directory table) 2481 // (we take the time stamp from the resource directory table)
2475 if (ImageNtHeaders.FileHeader.TimeDateStamp = BorlandMagicTimeStamp) then 2482 if (ImageNtHeaders.FileHeader.TimeDateStamp = BorlandMagicTimeStamp) then
2476 with ImageNtHeaders, FileHeader, OptionalHeader do begin 2483 with ImageNtHeaders, FileHeader, OptionalHeader do begin
2477 // Validate Optional header 2484 // Validate Optional header
2478 if (SizeOfOptionalHeader < IMAGE_SIZEOF_NT_OPTIONAL_HEADER) or (Magic <> IMAGE_NT_OPTIONAL_HDR_MAGIC) then 2485 if (SizeOfOptionalHeader < IMAGE_SIZEOF_NT_OPTIONAL_HEADER) or (Magic <> IMAGE_NT_OPTIONAL_HDR_MAGIC) then
2479 Exit; 2486 Exit;
2480 // Read section headers 2487 // Read section headers
2481 SectionHeaders := 2488 SectionHeaders :=
2482 GetMemory(NumberOfSections * SizeOf(TImageSectionHeader)); 2489 GetMemory(NumberOfSections * SizeOf(TImageSectionHeader));
2483 if Assigned(SectionHeaders) then try 2490 if Assigned(SectionHeaders) then try
2484 if (SetFilePointer(FileHandle, SizeOfOptionalHeader - IMAGE_SIZEOF_NT_OPTIONAL_HEADER, nil, FILE_CURRENT) = INVALID_SET_FILE_POINTER) then 2491 if (SetFilePointer(FileHandle, SizeOfOptionalHeader - IMAGE_SIZEOF_NT_OPTIONAL_HEADER, nil, FILE_CURRENT) = INVALID_SET_FILE_POINTER) then
2485 Exit; 2492 Exit;
2486 if not(ReadFile(FileHandle, SectionHeaders^, NumberOfSections * SizeOf(TImageSectionHeader), BytesRead, nil) and (BytesRead = NumberOfSections * SizeOf(TImageSectionHeader))) then 2493 if not(ReadFile(FileHandle, SectionHeaders^, NumberOfSections * SizeOf(TImageSectionHeader), BytesRead, nil) and (BytesRead = NumberOfSections * SizeOf(TImageSectionHeader))) then
2487 Exit; 2494 Exit;
2488 // Get RVA and size of the resource directory 2495 // Get RVA and size of the resource directory
2489 with DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE] do begin 2496 with DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE] do begin
2490 ResDirRVA := VirtualAddress; 2497 ResDirRVA := VirtualAddress;
2491 ResDirSize := Size; 2498 ResDirSize := Size;
2492 end; 2499 end;
2493 // Search for section which contains the resource directory 2500 // Search for section which contains the resource directory
2494 ResDirRaw := 0; 2501 ResDirRaw := 0;
2495 for Section := 0 to NumberOfSections - 1 do 2502 for Section := 0 to NumberOfSections - 1 do
2496 with SectionHeaders[Section] do 2503 with SectionHeaders[Section] do
2497 if (VirtualAddress <= ResDirRVA) and (VirtualAddress + SizeOfRawData >= ResDirRVA + ResDirSize) then begin 2504 if (VirtualAddress <= ResDirRVA) and (VirtualAddress + SizeOfRawData >= ResDirRVA + ResDirSize) then begin
2498 ResDirRaw := PointerToRawData - (VirtualAddress - ResDirRVA); 2505 ResDirRaw := PointerToRawData - (VirtualAddress - ResDirRVA);
2499 Break; 2506 Break;
2500 end; 2507 end;
2501 // Resource directory table found? 2508 // Resource directory table found?
2502 if (ResDirRaw = 0) then 2509 if (ResDirRaw = 0) then
2503 Exit; 2510 Exit;
2504 // Read resource directory table 2511 // Read resource directory table
2505 if (SetFilePointer(FileHandle, ResDirRaw, nil, FILE_BEGIN) = INVALID_SET_FILE_POINTER) then 2512 if (SetFilePointer(FileHandle, ResDirRaw, nil, FILE_BEGIN) = INVALID_SET_FILE_POINTER) then
2506 Exit; 2513 Exit;
2507 if not(ReadFile(FileHandle, ResDirTable, SizeOf(TImageResourceDirectory), BytesRead, nil) and (BytesRead = SizeOf(TImageResourceDirectory))) then 2514 if not(ReadFile(FileHandle, ResDirTable, SizeOf(TImageResourceDirectory), BytesRead, nil) and (BytesRead = SizeOf(TImageResourceDirectory))) then
2508 Exit; 2515 Exit;
2509 // Convert from DosDateTime to SecondsSince1970 2516 // Convert from DosDateTime to SecondsSince1970
2510 if DosDateTimeToFileTime(HiWord(ResDirTable.TimeDateStamp), LoWord(ResDirTable.TimeDateStamp), FileTime) then begin 2517 if DosDateTimeToFileTime(HiWord(ResDirTable.TimeDateStamp), LoWord(ResDirTable.TimeDateStamp), FileTime) then begin
2511 // FIXME: Borland's linker uses the local system time 2518 // FIXME: Borland's linker uses the local system time
2512 // of the user who linked the executable image file. 2519 // of the user who linked the executable image file.
2513 // (is that information anywhere?) 2520 // (is that information anywhere?)
2514 TimeStamp := (ULARGE_INTEGER(FileTime).QuadPart - ULARGE_INTEGER(FileTime1970).QuadPart) div 10000000; 2521 TimeStamp := (ULARGE_INTEGER(FileTime).QuadPart - ULARGE_INTEGER(FileTime1970).QuadPart) div 10000000;
2515 end; 2522 end;
2516 finally 2523 finally
2517 FreeMemory(SectionHeaders); 2524 FreeMemory(SectionHeaders);
2518 end; 2525 end;
2519 end; 2526 end;
2520 finally 2527 finally
2521 CloseHandle(FileHandle); 2528 CloseHandle(FileHandle);
2522 end; 2529 end;
2523 Result := UnixToDateTime(TimeStamp); 2530 Result := UnixToDateTime(TimeStamp);
2524 end; 2531 end;
2525 2532
2526 2533
2527 function IsEmpty(Str: String): Boolean; 2534 function IsEmpty(Str: String): Boolean;
2528 begin 2535 begin
2529 // Alternative version of "Str = ''" 2536 // Alternative version of "Str = ''"
2530 Result := Str = ''; 2537 Result := Str = '';
2531 end; 2538 end;
2532 2539
2533 function IsNotEmpty(Str: String): Boolean; 2540 function IsNotEmpty(Str: String): Boolean;
2534 begin 2541 begin
2535 // Alternative version of "Str <> ''" 2542 // Alternative version of "Str <> ''"
2536 Result := Str <> ''; 2543 Result := Str <> '';
2537 end; 2544 end;
2538 2545
2539 2546
2540 function MessageDialog(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer; 2547 function MessageDialog(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer;
2541 begin 2548 begin
2542 Result := MessageDialog('', Msg, DlgType, Buttons); 2549 Result := MessageDialog('', Msg, DlgType, Buttons);
2543 end; 2550 end;
2544 2551
2545 2552
2546 function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer; 2553 function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer;
2547 var 2554 var
2548 m: String; 2555 m: String;
2549 begin 2556 begin
2550 if (Win32MajorVersion >= 6) and (Title <> '') then 2557 if (Win32MajorVersion >= 6) and (Title <> '') then
2551 Result := TaskMessageDlg(Title, Msg, DlgType, Buttons, 0) 2558 Result := TaskMessageDlg(Title, Msg, DlgType, Buttons, 0)
2552 else begin 2559 else begin
2553 m := Msg; 2560 m := Msg;
2554 if Title <> '' then 2561 if Title <> '' then
2555 m := Title + CRLF + CRLF + m; 2562 m := Title + CRLF + CRLF + m;
2556 Result := MessageDlg(m, DlgType, Buttons, 0); 2563 Result := MessageDlg(m, DlgType, Buttons, 0);
2557 end; 2564 end;
2558 end; 2565 end;
2559 2566
2560 2567
2561 function ErrorDialog(Msg: string): Integer; 2568 function ErrorDialog(Msg: string): Integer;
2562 begin 2569 begin
2563 Result := MessageDialog(Msg, mtError, [mbOK]); 2570 Result := MessageDialog(Msg, mtError, [mbOK]);
2564 end; 2571 end;
2565 2572
2566 2573
2567 function ErrorDialog(const Title, Msg: string): Integer; 2574 function ErrorDialog(const Title, Msg: string): Integer;
2568 begin 2575 begin
2569 Result := MessageDialog(Title, Msg, mtError, [mbOK]); 2576 Result := MessageDialog(Title, Msg, mtError, [mbOK]);
2570 end; 2577 end;
2571 2578
2572 2579
2573 function GetHTMLCharsetByEncoding(Encoding: TEncoding): String; 2580 function GetHTMLCharsetByEncoding(Encoding: TEncoding): String;
2574 begin 2581 begin
2575 Result := ''; 2582 Result := '';
2576 if Encoding = TEncoding.Default then 2583 if Encoding = TEncoding.Default then
2577 Result := 'Windows-'+IntToStr(GetACP) 2584 Result := 'Windows-'+IntToStr(GetACP)
2578 else if Encoding = TEncoding.ASCII then 2585 else if Encoding = TEncoding.ASCII then
2579 Result := 'ascii' 2586 Result := 'ascii'
2580 else if Encoding = TEncoding.Unicode then 2587 else if Encoding = TEncoding.Unicode then
2581 Result := 'utf-16le' 2588 Result := 'utf-16le'
2582 else if Encoding = TEncoding.BigEndianUnicode then 2589 else if Encoding = TEncoding.BigEndianUnicode then
2583 Result := 'utf-16' 2590 Result := 'utf-16'
2584 else if Encoding = TEncoding.UTF8 then 2591 else if Encoding = TEncoding.UTF8 then
2585 Result := 'utf-8' 2592 Result := 'utf-8'
2586 else if Encoding = TEncoding.UTF7 then 2593 else if Encoding = TEncoding.UTF7 then
2587 Result := 'utf-7'; 2594 Result := 'utf-7';
2588 end; 2595 end;
2589 2596
2590 2597
2591 2598
2592 { Threading stuff } 2599 { Threading stuff }
2593 2600
2594 constructor TQueryThread.Create(Connection: TDBConnection; Batch: TSQLBatch; TabNumber: Integer); 2601 constructor TQueryThread.Create(Connection: TDBConnection; Batch: TSQLBatch; TabNumber: Integer);
2595 begin 2602 begin
2596 inherited Create(False); 2603 inherited Create(False);
2597 FConnection := Connection; 2604 FConnection := Connection;
2598 FAborted := False; 2605 FAborted := False;
2599 FBatch := Batch; 2606 FBatch := Batch;
2600 FTabNumber := TabNumber; 2607 FTabNumber := TabNumber;
2601 FBatchPosition := 0; 2608 FBatchPosition := 0;
2602 FQueryTime := 0; 2609 FQueryTime := 0;
2603 FQueryNetTime := 0; 2610 FQueryNetTime := 0;
2604 FRowsAffected := 0; 2611 FRowsAffected := 0;
2605 FRowsFound := 0; 2612 FRowsFound := 0;
2606 FWarningCount := 0; 2613 FWarningCount := 0;
2607 FErrorMessage := ''; 2614 FErrorMessage := '';
2608 FBatchInOneGo := MainForm.actBatchInOneGo.Checked; 2615 FBatchInOneGo := MainForm.actBatchInOneGo.Checked;
2609 FStopOnErrors := MainForm.actQueryStopOnErrors.Checked; 2616 FStopOnErrors := MainForm.actQueryStopOnErrors.Checked;
2610 FreeOnTerminate := True; 2617 FreeOnTerminate := True;
2611 Priority := tpNormal; 2618 Priority := tpNormal;
2612 end; 2619 end;
2613 2620
2614 2621
2615 procedure TQueryThread.Execute; 2622 procedure TQueryThread.Execute;
2616 var 2623 var
2617 SQL: String; 2624 SQL: String;
2618 i, BatchStartOffset, ResultCount: Integer; 2625 i, BatchStartOffset, ResultCount: Integer;
2619 PacketSize, MaxAllowedPacket: Int64; 2626 PacketSize, MaxAllowedPacket: Int64;
2620 DoStoreResult, ErrorAborted: Boolean; 2627 DoStoreResult, ErrorAborted: Boolean;
2621 begin 2628 begin
2622 inherited; 2629 inherited;
2623 2630
2624 MaxAllowedPacket := 0; 2631 MaxAllowedPacket := 0;
2625 i := 0; 2632 i := 0;
2626 ResultCount := 0; 2633 ResultCount := 0;
2627 ErrorAborted := False; 2634 ErrorAborted := False;
2628 2635
2629 while i < FBatch.Count do begin 2636 while i < FBatch.Count do begin
2630 SQL := ''; 2637 SQL := '';
2631 if not FBatchInOneGo then begin 2638 if not FBatchInOneGo then begin
2632 SQL := FBatch[i].SQL; 2639 SQL := FBatch[i].SQL;
2633 Inc(i); 2640 Inc(i);
2634 end else begin 2641 end else begin
2635 // Concat queries up to a size of max_allowed_packet 2642 // Concat queries up to a size of max_allowed_packet
2636 if MaxAllowedPacket = 0 then begin 2643 if MaxAllowedPacket = 0 then begin
2637 if FConnection.Parameters.NetTypeGroup = ngMySQL then begin 2644 if FConnection.Parameters.NetTypeGroup = ngMySQL then begin
2638 FConnection.LockedByThread := Self; 2645 FConnection.LockedByThread := Self;
2639 MaxAllowedPacket := MakeInt(FConnection.GetVar('SHOW VARIABLES LIKE '+esc('max_allowed_packet'), 1)); 2646 MaxAllowedPacket := MakeInt(FConnection.GetVar('SHOW VARIABLES LIKE '+esc('max_allowed_packet'), 1));
2640 FConnection.LockedByThread := nil; 2647 FConnection.LockedByThread := nil;
2641 end else 2648 end else
2642 MaxAllowedPacket := SIZE_MB; 2649 MaxAllowedPacket := SIZE_MB;
2643 // TODO: Log('Detected maximum allowed packet size: '+FormatByteNumber(MaxAllowedPacket), lcDebug); 2650 // TODO: Log('Detected maximum allowed packet size: '+FormatByteNumber(MaxAllowedPacket), lcDebug);
2644 end; 2651 end;
2645 BatchStartOffset := FBatch[i].LeftOffset; 2652 BatchStartOffset := FBatch[i].LeftOffset;
2646 while i < FBatch.Count do begin 2653 while i < FBatch.Count do begin
2647 PacketSize := FBatch[i].RightOffset - BatchStartOffset + ((i-FBatchPosition) * 10); 2654 PacketSize := FBatch[i].RightOffset - BatchStartOffset + ((i-FBatchPosition) * 10);
2648 if (PacketSize >= MaxAllowedPacket) or (i-FBatchPosition >= 50) then begin 2655 if (PacketSize >= MaxAllowedPacket) or (i-FBatchPosition >= 50) then begin
2649 // TODO: Log('Limiting batch packet size to '+FormatByteNumber(Length(SQL))+' with '+FormatNumber(i-FUserQueryOffset)+' queries.', lcDebug); 2656 // TODO: Log('Limiting batch packet size to '+FormatByteNumber(Length(SQL))+' with '+FormatNumber(i-FUserQueryOffset)+' queries.', lcDebug);
2650 Dec(i); 2657 Dec(i);
2651 break; 2658 break;
2652 end; 2659 end;
2653 SQL := SQL + FBatch[i].SQL + ';'; 2660 SQL := SQL + FBatch[i].SQL + ';';
2654 Inc(i); 2661 Inc(i);
2655 end; 2662 end;
2656 FQueriesInPacket := i - FBatchPosition; 2663 FQueriesInPacket := i - FBatchPosition;
2657 end; 2664 end;
2658 Synchronize(BeforeQuery); 2665 Synchronize(BeforeQuery);
2659 try 2666 try
2660 FConnection.LockedByThread := Self; 2667 FConnection.LockedByThread := Self;
2661 DoStoreResult := ResultCount < Mainform.prefMaxQueryResults; 2668 DoStoreResult := ResultCount < Mainform.prefMaxQueryResults;
2662 FConnection.Query(SQL, DoStoreResult, lcUserFiredSQL); 2669 FConnection.Query(SQL, DoStoreResult, lcUserFiredSQL);
2663 Inc(ResultCount, FConnection.ResultCount); 2670 Inc(ResultCount, FConnection.ResultCount);
2664 FBatchPosition := i; 2671 FBatchPosition := i;
2665 Inc(FQueryTime, FConnection.LastQueryDuration); 2672 Inc(FQueryTime, FConnection.LastQueryDuration);
2666 Inc(FQueryNetTime, FConnection.LastQueryNetworkDuration); 2673 Inc(FQueryNetTime, FConnection.LastQueryNetworkDuration);
2667 Inc(FRowsAffected, FConnection.RowsAffected); 2674 Inc(FRowsAffected, FConnection.RowsAffected);
2668 Inc(FRowsFound, FConnection.RowsFound); 2675 Inc(FRowsFound, FConnection.RowsFound);
2669 Inc(FWarningCount, FConnection.WarningCount); 2676 Inc(FWarningCount, FConnection.WarningCount);
2670 except 2677 except
2671 on E:EDatabaseError do begin 2678 on E:EDatabaseError do begin
2672 if FStopOnErrors or (i = FBatch.Count - 1) then begin 2679 if FStopOnErrors or (i = FBatch.Count - 1) then begin
2673 FErrorMessage := E.Message; 2680 FErrorMessage := E.Message;
2674 ErrorAborted := True; 2681 ErrorAborted := True;
2675 end; 2682 end;
2676 end; 2683 end;
2677 end; 2684 end;
2678 FConnection.LockedByThread := nil; 2685 FConnection.LockedByThread := nil;
2679 Synchronize(AfterQuery); 2686 Synchronize(AfterQuery);
2680 // Check if FAborted is set by the main thread, to avoid proceeding the loop in case 2687 // Check if FAborted is set by the main thread, to avoid proceeding the loop in case
2681 // FStopOnErrors is set to false 2688 // FStopOnErrors is set to false
2682 if FAborted or ErrorAborted then 2689 if FAborted or ErrorAborted then
2683 break; 2690 break;
2684 end; 2691 end;
2685 2692
2686 Synchronize(BatchFinished); 2693 Synchronize(BatchFinished);
2687 end; 2694 end;
2688 2695
2689 2696
2690 procedure TQueryThread.BeforeQuery; 2697 procedure TQueryThread.BeforeQuery;
2691 begin 2698 begin
2692 MainForm.BeforeQueryExecution(Self); 2699 MainForm.BeforeQueryExecution(Self);
2693 end; 2700 end;
2694 2701
2695 2702
2696 procedure TQueryThread.LogFromOutside(Msg: String; Category: TDBLogCategory); 2703 procedure TQueryThread.LogFromOutside(Msg: String; Category: TDBLogCategory);
2697 begin 2704 begin
2698 FLogMsg := Msg; 2705 FLogMsg := Msg;
2699 FLogCategory := Category; 2706 FLogCategory := Category;
2700 Synchronize(Log); 2707 Synchronize(Log);
2701 end; 2708 end;
2702 2709
2703 2710
2704 procedure TQueryThread.Log; 2711 procedure TQueryThread.Log;
2705 begin 2712 begin
2706 FConnection.OnLog(FLogMsg, FLogCategory, FConnection); 2713 FConnection.OnLog(FLogMsg, FLogCategory, FConnection);
2707 end; 2714 end;
2708 2715
2709 2716
2710 procedure TQueryThread.AfterQuery; 2717 procedure TQueryThread.AfterQuery;
2711 begin 2718 begin
2712 MainForm.AfterQueryExecution(Self); 2719 MainForm.AfterQueryExecution(Self);
2713 end; 2720 end;
2714 2721
2715 2722
2716 procedure TQueryThread.BatchFinished; 2723 procedure TQueryThread.BatchFinished;
2717 begin 2724 begin
2718 MainForm.FinishedQueryExecution(Self); 2725 MainForm.FinishedQueryExecution(Self);
2719 end; 2726 end;
2720 2727
2721 2728
2722 { TSQLSentence } 2729 { TSQLSentence }
2723 2730
2724 constructor TSQLSentence.Create(Owner: TSQLBatch); 2731 constructor TSQLSentence.Create(Owner: TSQLBatch);
2725 begin 2732 begin
2726 // Use a back reference to the parent batch object, so we can extract SQL from it 2733 // Use a back reference to the parent batch object, so we can extract SQL from it
2727 FOwner := Owner; 2734 FOwner := Owner;
2728 end; 2735 end;
2729 2736
2730 2737
2731 function TSQLSentence.GetSize: Integer; 2738 function TSQLSentence.GetSize: Integer;
2732 begin 2739 begin
2733 Result := RightOffset - LeftOffset; 2740 Result := RightOffset - LeftOffset;
2734 end; 2741 end;
2735 2742
2736 2743
2737 function TSQLSentence.GetSQL: String; 2744 function TSQLSentence.GetSQL: String;
2738 begin 2745 begin
2739 Result := Copy(FOwner.SQL, LeftOffset, RightOffset-LeftOffset); 2746 Result := Copy(FOwner.SQL, LeftOffset, RightOffset-LeftOffset);
2740 end; 2747 end;
2741 2748
2742 2749
2743 { TSQLBatch } 2750 { TSQLBatch }
2744 2751
2745 function TSQLBatch.GetSize: Integer; 2752 function TSQLBatch.GetSize: Integer;
2746 var 2753 var
2747 Query: TSQLSentence; 2754 Query: TSQLSentence;
2748 begin 2755 begin
2749 // Return overall string length of batch 2756 // Return overall string length of batch
2750 Result := 0; 2757 Result := 0;
2751 for Query in Self do 2758 for Query in Self do
2752 Inc(Result, Query.Size); 2759 Inc(Result, Query.Size);
2753 end; 2760 end;
2754 2761
2755 2762
2756 procedure TSQLBatch.SetSQL(Value: String); 2763 procedure TSQLBatch.SetSQL(Value: String);
2757 var 2764 var
2758 i, AllLen, DelimLen, DelimStart, LastLeftOffset, RightOffset, LastNewLineOffset: Integer; 2765 i, AllLen, DelimLen, DelimStart, LastLeftOffset, RightOffset, LastNewLineOffset: Integer;
2759 c, n, LastStringEncloser: Char; 2766 c, n, LastStringEncloser: Char;
2760 Delim, DelimTest, QueryTest: String; 2767 Delim, DelimTest, QueryTest: String;
2761 InString, InComment, InBigComment, InEscape: Boolean; 2768 InString, InComment, InBigComment, InEscape: Boolean;
2762 Marker: TSQLSentence; 2769 Marker: TSQLSentence;
2763 rx: TRegExpr; 2770 rx: TRegExpr;
2764 const 2771 const
2765 StringEnclosers = ['"', '''', '`']; 2772 StringEnclosers = ['"', '''', '`'];
2766 NewLines = [#13, #10]; 2773 NewLines = [#13, #10];
2767 WhiteSpaces = NewLines + [#9, ' ']; 2774 WhiteSpaces = NewLines + [#9, ' '];
2768 begin 2775 begin
2769 // Scan SQL batch for delimiters and store a list with start + end offsets 2776 // Scan SQL batch for delimiters and store a list with start + end offsets
2770 FSQL := Value; 2777 FSQL := Value;
2771 Clear; 2778 Clear;
2772 AllLen := Length(FSQL); 2779 AllLen := Length(FSQL);
2773 i := 0; 2780 i := 0;
2774 LastLeftOffset := 1; 2781 LastLeftOffset := 1;
2775 Delim := Mainform.Delimiter; 2782 Delim := Mainform.Delimiter;
2776 InString := False; // Loop in "enclosed string" or `identifier` 2783 InString := False; // Loop in "enclosed string" or `identifier`
2777 InComment := False; // Loop in one-line comment (# or --) 2784 InComment := False; // Loop in one-line comment (# or --)
2778 InBigComment := False; // Loop in /* multi-line */ or /*! condictional comment */ 2785 InBigComment := False; // Loop in /* multi-line */ or /*! condictional comment */
2779 InEscape := False; // Previous char was backslash 2786 InEscape := False; // Previous char was backslash
2780 LastStringEncloser := #0; 2787 LastStringEncloser := #0;
2781 DelimLen := Length(Delim); 2788 DelimLen := Length(Delim);
2782 rx := TRegExpr.Create; 2789 rx := TRegExpr.Create;
2783 rx.Expression := '^\s*DELIMITER\s+(\S+)'; 2790 rx.Expression := '^\s*DELIMITER\s+(\S+)';
2784 rx.ModifierG := True; 2791 rx.ModifierG := True;
2785 rx.ModifierI := True; 2792 rx.ModifierI := True;
2786 rx.ModifierM := False; 2793 rx.ModifierM := False;
2787 while i < AllLen do begin 2794 while i < AllLen do begin
2788 Inc(i); 2795 Inc(i);
2789 // Current and next char 2796 // Current and next char
2790 c := FSQL[i]; 2797 c := FSQL[i];
2791 if i < AllLen then n := FSQL[i+1] 2798 if i < AllLen then n := FSQL[i+1]
2792 else n := #0; 2799 else n := #0;
2793 2800
2794 // Check for comment syntax and for enclosed literals, so a query delimiter can be ignored 2801 // Check for comment syntax and for enclosed literals, so a query delimiter can be ignored
2795 if (not InComment) and (not InBigComment) and (not InString) and ((c + n = '--') or (c = '#')) then 2802 if (not InComment) and (not InBigComment) and (not InString) and ((c + n = '--') or (c = '#')) then
2796 InComment := True; 2803 InComment := True;
2797 if (not InComment) and (not InBigComment) and (not InString) and (c + n = '/*') then 2804 if (not InComment) and (not InBigComment) and (not InString) and (c + n = '/*') then
2798 InBigComment := True; 2805 InBigComment := True;
2799 if InBigComment and (not InComment) and (not InString) and (c + n = '*/') then 2806 if InBigComment and (not InComment) and (not InString) and (c + n = '*/') then
2800 InBigComment := False; 2807 InBigComment := False;
2801 if (not InEscape) and (not InComment) and (not InBigComment) and CharInSet(c, StringEnclosers) then begin 2808 if (not InEscape) and (not InComment) and (not InBigComment) and CharInSet(c, StringEnclosers) then begin
2802 if (not InString) or (InString and (c = LastStringEncloser)) then begin 2809 if (not InString) or (InString and (c = LastStringEncloser)) then begin
2803 InString := not InString; 2810 InString := not InString;
2804 LastStringEncloser := c; 2811 LastStringEncloser := c;
2805 end; 2812 end;
2806 end; 2813 end;
2807 if (CharInSet(c, NewLines) and (not CharInSet(n, NewLines))) or (i = 1) then begin 2814 if (CharInSet(c, NewLines) and (not CharInSet(n, NewLines))) or (i = 1) then begin
2808 if i > 1 then 2815 if i > 1 then
2809 InComment := False; 2816 InComment := False;
2810 if (not InString) and (not InBigComment) and rx.Exec(copy(FSQL, i, 100)) then begin 2817 if (not InString) and (not InBigComment) and rx.Exec(copy(FSQL, i, 100)) then begin
2811 Delim := rx.Match[1]; 2818 Delim := rx.Match[1];
2812 DelimLen := rx.MatchLen[1]; 2819 DelimLen := rx.MatchLen[1];
2813 Inc(i, rx.MatchLen[0]); 2820 Inc(i, rx.MatchLen[0]);
2814 LastLeftOffset := i; 2821 LastLeftOffset := i;
2815 continue; 2822 continue;
2816 end; 2823 end;
2817 end; 2824 end;
2818 if not InEscape then 2825 if not InEscape then
2819 InEscape := c = '\' 2826 InEscape := c = '\'
2820 else 2827 else
2821 InEscape := False; 2828 InEscape := False;
2822 2829
2823 // Prepare delimiter test string 2830 // Prepare delimiter test string
2824 if (not InComment) and (not InString) and (not InBigComment) then begin 2831 if (not InComment) and (not InString) and (not InBigComment) then begin
2825 DelimStart := Max(1, i+1-DelimLen); 2832 DelimStart := Max(1, i+1-DelimLen);
2826 DelimTest := Copy(FSQL, DelimStart, i-Max(i-DelimLen, 0)); 2833 DelimTest := Copy(FSQL, DelimStart, i-Max(i-DelimLen, 0));
2827 end else 2834 end else
2828 DelimTest := ''; 2835 DelimTest := '';
2829 2836
2830 // End of query or batch reached. Add query markers to result list if sentence is not empty. 2837 // End of query or batch reached. Add query markers to result list if sentence is not empty.
2831 if (DelimTest = Delim) or (i = AllLen) then begin 2838 if (DelimTest = Delim) or (i = AllLen) then begin
2832 RightOffset := i+1; 2839 RightOffset := i+1;
2833 if DelimTest = Delim then 2840 if DelimTest = Delim then
2834 Dec(RightOffset, DelimLen); 2841 Dec(RightOffset, DelimLen);
2835 QueryTest := Trim(Copy(FSQL, LastLeftOffset, RightOffset-LastLeftOffset)); 2842 QueryTest := Trim(Copy(FSQL, LastLeftOffset, RightOffset-LastLeftOffset));
2836 if (QueryTest <> '') and (QueryTest <> Delim) then begin 2843 if (QueryTest <> '') and (QueryTest <> Delim) then begin
2837 Marker := TSQLSentence.Create(Self); 2844 Marker := TSQLSentence.Create(Self);
2838 while CharInSet(FSQL[LastLeftOffset], WhiteSpaces) do 2845 while CharInSet(FSQL[LastLeftOffset], WhiteSpaces) do
2839 Inc(LastLeftOffset); 2846 Inc(LastLeftOffset);
2840 Marker.LeftOffset := LastLeftOffset; 2847 Marker.LeftOffset := LastLeftOffset;
2841 Marker.RightOffset := RightOffset; 2848 Marker.RightOffset := RightOffset;
2842 Add(Marker); 2849 Add(Marker);
2843 LastLeftOffset := i+1; 2850 LastLeftOffset := i+1;
2844 end; 2851 end;
2845 end; 2852 end;
2846 end; 2853 end;
2847 end; 2854 end;
2848 2855
2849 2856
2850 { THttpDownload } 2857 { THttpDownload }
2851 2858
2852 constructor THttpDownload.Create(Owner: TComponent); 2859 constructor THttpDownload.Create(Owner: TComponent);
2853 begin 2860 begin
2854 FBytesRead := -1; 2861 FBytesRead := -1;
2855 FContentLength := -1; 2862 FContentLength := -1;
2856 FOwner := Owner; 2863 FOwner := Owner;
2857 end; 2864 end;
2858 2865
2859 2866
2860 procedure THttpDownload.SendRequest(Filename: String); 2867 procedure THttpDownload.SendRequest(Filename: String);
2861 var 2868 var
2862 NetHandle: HINTERNET; 2869 NetHandle: HINTERNET;
2863 UrlHandle: HINTERNET; 2870 UrlHandle: HINTERNET;
2864 Buffer: array[1..4096] of Byte; 2871 Buffer: array[1..4096] of Byte;
2865 Head: array[1..1024] of Char; 2872 Head: array[1..1024] of Char;
2866 BytesInChunk, HeadSize, Reserved: Cardinal; 2873 BytesInChunk, HeadSize, Reserved: Cardinal;
2867 LocalFile: File; 2874 LocalFile: File;
2868 DoStore: Boolean; 2875 DoStore: Boolean;
2869 UserAgent, OS: String; 2876 UserAgent, OS: String;
2870 HttpStatus: Integer; 2877 HttpStatus: Integer;
2871 begin 2878 begin
2872 DoStore := False; 2879 DoStore := False;
2873 if MainForm.IsWine then 2880 if MainForm.IsWine then
2874 OS := 'Linux/Wine' 2881 OS := 'Linux/Wine'
2875 else 2882 else
2876 OS := 'Windows NT '+IntToStr(Win32MajorVersion)+'.'+IntToStr(Win32MinorVersion); 2883 OS := 'Windows NT '+IntToStr(Win32MajorVersion)+'.'+IntToStr(Win32MinorVersion);
2877 UserAgent := APPNAME+'/'+MainForm.AppVersion+' ('+OS+'; '+ExtractFilename(Application.ExeName)+'; '+FOwner.Name+')'; 2884 UserAgent := APPNAME+'/'+MainForm.AppVersion+' ('+OS+'; '+ExtractFilename(Application.ExeName)+'; '+FOwner.Name+')';
2878 NetHandle := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); 2885 NetHandle := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
2879 2886
2880 try 2887 try
2881 UrlHandle := InternetOpenURL(NetHandle, PChar(FURL), nil, 0, INTERNET_FLAG_RELOAD, 0); 2888 UrlHandle := InternetOpenURL(NetHandle, PChar(FURL), nil, 0, INTERNET_FLAG_RELOAD, 0);
2882 if not Assigned(UrlHandle) then 2889 if not Assigned(UrlHandle) then
2883 raise Exception.Create('Could not open URL: '+FURL); 2890 raise Exception.Create('Could not open URL: '+FURL);
2884 2891
2885 // Detect content length 2892 // Detect content length
2886 HeadSize := SizeOf(Head); 2893 HeadSize := SizeOf(Head);
2887 Reserved := 0; 2894 Reserved := 0;
2888 if HttpQueryInfo(UrlHandle, HTTP_QUERY_CONTENT_LENGTH, @Head, HeadSize, Reserved) then 2895 if HttpQueryInfo(UrlHandle, HTTP_QUERY_CONTENT_LENGTH, @Head, HeadSize, Reserved) then
2889 FContentLength := StrToIntDef(Head, -1) 2896 FContentLength := StrToIntDef(Head, -1)
2890 else 2897 else
2891 raise Exception.Create('Server did not send required "Content-Length" header: '+FURL); 2898 raise Exception.Create('Server did not send required "Content-Length" header: '+FURL);
2892 2899
2893 // Check if we got HTTP status 200 2900 // Check if we got HTTP status 200
2894 HeadSize := SizeOf(Head); 2901 HeadSize := SizeOf(Head);
2895 Reserved := 0; 2902 Reserved := 0;
2896 if HttpQueryInfo(UrlHandle, HTTP_QUERY_STATUS_CODE, @Head, HeadSize, Reserved) then begin 2903 if HttpQueryInfo(UrlHandle, HTTP_QUERY_STATUS_CODE, @Head, HeadSize, Reserved) then begin
2897 HttpStatus := StrToIntDef(Head, -1); 2904 HttpStatus := StrToIntDef(Head, -1);
2898 if HttpStatus <> 200 then 2905 if HttpStatus <> 200 then
2899 raise Exception.Create('Got HTTP status '+IntToStr(HttpStatus)+' from '+FURL); 2906 raise Exception.Create('Got HTTP status '+IntToStr(HttpStatus)+' from '+FURL);
2900 end; 2907 end;
2901 2908
2902 // Create local file 2909 // Create local file
2903 if Filename <> '' then begin 2910 if Filename <> '' then begin
2904 AssignFile(LocalFile, FileName); 2911 AssignFile(LocalFile, FileName);
2905 Rewrite(LocalFile, 1); 2912 Rewrite(LocalFile, 1);
2906 DoStore := True; 2913 DoStore := True;
2907 end; 2914 end;
2908 2915
2909 // Stream contents 2916 // Stream contents
2910 while true do begin 2917 while true do begin
2911 InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesInChunk); 2918 InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesInChunk);
2912 if DoStore then 2919 if DoStore then
2913 BlockWrite(LocalFile, Buffer, BytesInChunk); 2920 BlockWrite(LocalFile, Buffer, BytesInChunk);
2914 Inc(FBytesRead, BytesInChunk); 2921 Inc(FBytesRead, BytesInChunk);
2915 if Assigned(FOnProgress) then 2922 if Assigned(FOnProgress) then
2916 FOnProgress(Self); 2923 FOnProgress(Self);
2917 if BytesInChunk = 0 then 2924 if BytesInChunk = 0 then
2918 break; 2925 break;
2919 end; 2926 end;
2920 2927
2921 finally 2928 finally
2922 if DoStore then 2929 if DoStore then
2923 CloseFile(LocalFile); 2930 CloseFile(LocalFile);
2924 if Assigned(UrlHandle) then 2931 if Assigned(UrlHandle) then
2925 InternetCloseHandle(UrlHandle); 2932 InternetCloseHandle(UrlHandle);
2926 if Assigned(NetHandle) then 2933 if Assigned(NetHandle) then
2927 InternetCloseHandle(NetHandle); 2934 InternetCloseHandle(NetHandle);
2928 end; 2935 end;
2929 end; 2936 end;
2930 2937
2931 2938
2932 2939
2933 2940
2934 end. 2941 end.
2935 2942
2936 2943
Powered by Google Project Hosting