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