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