unit helpers; // ------------------------------------- // Functions-library // ------------------------------------- interface uses Classes, SysUtils, Graphics, GraphUtil, ClipBrd, Dialogs, Forms, Controls, ShellApi, Windows, ShlObj, ActiveX, VirtualTrees, SynRegExpr, Messages, Math, Registry, DateUtils, Generics.Collections, StrUtils, AnsiStrings, TlHelp32, Types, dbconnection, mysql_structures, SynMemo, Menus, WinInet, gnugettext, Themes, Character, ImgList, System.UITypes, ActnList, WinSock, IOUtils; type TOrderCol = class(TObject) ColumnName: String; SortDirection: Byte; end; TOrderColArray = Array of TOrderCol; TLineBreaks = (lbsNone, lbsWindows, lbsUnix, lbsMac, lbsWide, lbsMixed); TDBObjectEditor = class(TFrame) private FModified: Boolean; FDefiners: TStringList; procedure SetModified(Value: Boolean); protected public DBObject: TDBObject; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Init(Obj: TDBObject); virtual; function DeInit: TModalResult; function GetDefiners: TStringList; property Modified: Boolean read FModified write SetModified; function ApplyModifications: TModalResult; virtual; abstract; end; TDBObjectEditorClass = class of TDBObjectEditor; TSQLBatch = class; TSQLSentence = class(TObject) private FOwner: TSQLBatch; function GetSize: Integer; function GetSQL: String; public LeftOffset, RightOffset: Integer; constructor Create(Owner: TSQLBatch); property SQL: String read GetSQL; property Size: Integer read GetSize; end; TSQLBatch = class(TObjectList) private FSQL: String; procedure SetSQL(Value: String); function GetSize: Integer; public property Size: Integer read GetSize; property SQL: String read FSQL write SetSQL; end; // Download THttpDownload = class(TObject) private FOwner: TComponent; FURL: String; FBytesRead: Integer; FContentLength: Integer; FTimeOut: Cardinal; FOnProgress: TNotifyEvent; public constructor Create(Owner: TComponent); procedure SendRequest(Filename: String); property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; property URL: String read FURL write FURL; property TimeOut: Cardinal read FTimeOut write FTimeOut; property BytesRead: Integer read FBytesRead; property ContentLength: Integer read FContentLength; end; // Threading stuff TQueryThread = class(TThread) private FConnection: TDBConnection; FBatch: TSQLBatch; FTabNumber: Integer; FBatchInOneGo: Boolean; FStopOnErrors: Boolean; FAborted: Boolean; FErrorMessage: String; FBatchPosition: Integer; FQueriesInPacket: Integer; FQueryTime: Cardinal; FQueryNetTime: Cardinal; FRowsAffected: Int64; FRowsFound: Int64; FWarningCount: Int64; FLogMsg: String; FLogCategory: TDBLogCategory; procedure BeforeQuery; procedure AfterQuery; procedure BatchFinished; procedure Log; public property Connection: TDBConnection read FConnection; property Batch: TSQLBatch read FBatch; property TabNumber: Integer read FTabNumber; property BatchPosition: Integer read FBatchPosition; property QueriesInPacket: Integer read FQueriesInPacket; property QueryTime: Cardinal read FQueryTime; property QueryNetTime: Cardinal read FQueryNetTime; property RowsAffected: Int64 read FRowsAffected; property RowsFound: Int64 read FRowsFound; property WarningCount: Int64 read FWarningCount; property Aborted: Boolean read FAborted write FAborted; property ErrorMessage: String read FErrorMessage; constructor Create(Connection: TDBConnection; Batch: TSQLBatch; TabNumber: Integer); procedure Execute; override; procedure LogFromOutside(Msg: String; Category: TDBLogCategory); end; TAppSettingDataType = (adInt, adBool, adString); TAppSettingIndex = (asHiddenColumns, asFilter, asSort, asDisplayedColumnsSorted, asLastSessions, asLastActiveSession, asAutoReconnect, asRestoreLastUsedDB, asLastUsedDB, asTreeBackground, asFontName, asFontSize, asTabWidth, asDataFontName, asDataFontSize, asDataLocalNumberFormat, asHintsOnResultTabs, asLogsqlnum, asLogsqlwidth, asSessionLogsDirectory, asLogHorizontalScrollbar, asSQLColActiveLine, asSQLColMatchingBraceForeground, asSQLColMatchingBraceBackground, asMaxColWidth, asDatagridMaximumRows, asDatagridRowsPerStep, asGridRowLineCount, asReuseEditorConfiguration, asLogToFile, asMainWinMaximized, asMainWinLeft, asMainWinTop, asMainWinWidth, asMainWinHeight, asMainWinOnMonitor, asCoolBandIndex, asCoolBandBreak, asCoolBandWidth, asQuerymemoheight, asDbtreewidth, asDataPreviewHeight, asDataPreviewEnabled, asLogHeight, asQueryhelperswidth, asStopOnErrorsInBatchMode, asWrapLongLines, asDisplayBLOBsAsText, asSingleQueries, asMemoEditorWidth, asMemoEditorHeight, asMemoEditorWrap, asDelimiter, asSQLHelpWindowLeft, asSQLHelpWindowTop, asSQLHelpWindowWidth, asSQLHelpWindowHeight, asSQLHelpPnlLeftWidth, asSQLHelpPnlRightTopHeight, asTableEditorTabsHeight, asHost, asUser, asPassword, asWindowsAuth, asLoginPrompt, asPort, asPlinkExecutable, asSSHtunnelHost, asSSHtunnelHostPort, asSSHtunnelPort, asSSHtunnelUser, asSSHtunnelPassword, asSSHtunnelTimeout, asSSHtunnelPrivateKey, asSSLActive, asSSLKey, asSSLCert, asSSLCA, asSSLCipher, asNetType, asCompressed, asLocalTimeZone, asQueryTimeout, asKeepAlive, asStartupScriptFilename, asDatabases, asComment, asDatabaseFilter, asTableFilter, asExportSQLCreateDatabases, asExportSQLCreateTables, asExportSQLDataHow, asExportSQLDataInsertSize, asExportSQLFilenames, asExportZIPFilenames, asExportSQLDirectories, asExportSQLDatabase, asExportSQLServerDatabase, asExportSQLOutput, asExportSQLAddComments, asExportSQLRemoveAutoIncrement, asGridExportOutputCopy, asGridExportOutputFile, asGridExportFilename, asGridExportRecentFiles, asGridExportEncoding, asGridExportFormat, asGridExportSelection, asGridExportColumnNames, asGridExportIncludeAutoInc, asGridExportIncludeQuery, asGridExportSeparator, asGridExportEncloser, asGridExportTerminator, asGridExportNull, asGridExportClpFormat, asGridExportClpColumnNames, asGridExportClpIncludeAutoInc, asGridExportClpSeparator, asGridExportClpEncloser, asGridExportClpTerminator, asGridExportClpNull, asCSVImportSeparator, asCSVImportEncloser, asCSVImportTerminator, asCSVImportFieldEscaper, asCSVImportWindowWidth, asCSVImportWindowHeight, asCSVImportFilename, asCSVImportFieldsEnclosedOptionally, asCSVImportIgnoreLines, asCSVImportLowPriority, asCSVImportLocalNumbers, asCSVImportDuplicateHandling, asCSVImportParseMethod, asUpdatecheck, asUpdatecheckBuilds, asUpdatecheckInterval, asUpdatecheckLastrun, asTableToolsWindowWidth, asTableToolsWindowHeight, asTableToolsTreeWidth, asTableToolsFindText, asTableToolsDatatype, asTableToolsFindCaseSensitive, asTableToolsFindMatchType, asFileImportWindowWidth, asFileImportWindowHeight, asEditVarWindowWidth, asEditVarWindowHeight, asUsermanagerWindowWidth, asUsermanagerWindowHeight, asUsermanagerListWidth, asSelectDBOWindowWidth, asSelectDBOWindowHeight, asSessionManagerListWidth, asSessionManagerWindowWidth, asSessionManagerWindowHeight, asCopyTableWindowHeight, asCopyTableWindowWidth, asCopyTableColumns, asCopyTableKeys, asCopyTableForeignKeys, asCopyTableData, asCopyTableRecentFilter, asServerVersion, asServerVersionFull, asLastConnect, asConnectCount, asRefusedCount, asSessionCreated, asDoUsageStatistics, asLastUsageStatisticCall, asDisplayBars, asBarColor, asMySQLBinaries, asCustomSnippetsDirectory, asPromptSaveFileOnTabClose, asWarnUnsafeUpdates, asCompletionProposal, asCompletionProposalWidth, asCompletionProposalNbLinesInWindow, asTabsToSpaces, asFilterPanel, asAllowMultipleInstances, asFindDialogSearchHistory, asGUIFontName, asGUIFontSize, asFindDialogReplaceHistory, asMaxQueryResults, asLogErrors, asLogUserSQL, asLogSQL, asLogInfos, asLogDebug, asFieldColorNumeric, asFieldColorReal, asFieldColorText, asFieldColorBinary, asFieldColorDatetime, asFieldColorSpatial, asFieldColorOther, asFieldEditorBinary, asFieldEditorDatetime, asFieldEditorDatetimePrefill, asFieldEditorEnum, asFieldEditorSet, asFieldNullBackground, asRowBackgroundEven, asRowBackgroundOdd, asGroupTreeObjects, asDisplayObjectSizeColumn, asSQLfile, asActionShortcut1, asActionShortcut2, asHighlighterForeground, asHighlighterBackground, asHighlighterStyle, asListColWidths, asListColsVisible, asListColPositions, asListColSort, asSessionFolder, asRecentFilter, asTimestampColumns, asDateTimeEditorCursorPos, asAppLanguage, asAutoExpand, asDoubleClickInsertsNodeText, asForeignDropDown, asQueryHistoryEnabled, asQueryHistoryKeepDays, asColumnSelectorWidth, asColumnSelectorHeight, asDonatedEmail, asFavoriteObjects, asFavoriteObjectsOnly, asFullTableStatus, asLineBreakStyle, asFileDialogEncoding, asUnused); TAppSetting = record Name: String; Session: Boolean; DefaultInt, CurrentInt: Integer; DefaultBool, CurrentBool: Boolean; DefaultString, CurrentString: String; Synced: Boolean; end; TAppSettings = class(TObject) private FReads, FWrites: Integer; FBasePath: String; FSessionPath: String; FRegistry: TRegistry; FPortableMode: Boolean; FSettingsFile: String; FSettings: Array[TAppSettingIndex] of TAppSetting; procedure InitSetting(Index: TAppSettingIndex; Name: String; DefaultInt: Integer=0; DefaultBool: Boolean=False; DefaultString: String=''; Session: Boolean=False); procedure SetSessionPath(Value: String); procedure PrepareRegistry; procedure Read(Index: TAppSettingIndex; FormatName: String; DataType: TAppSettingDataType; var I: Integer; var B: Boolean; var S: String; DI: Integer; DB: Boolean; DS: String); procedure Write(Index: TAppSettingIndex; FormatName: String; DataType: TAppSettingDataType; I: Integer; B: Boolean; S: String); public constructor Create; destructor Destroy; override; function ReadInt(Index: TAppSettingIndex; FormatName: String=''; Default: Integer=0): Integer; function ReadBool(Index: TAppSettingIndex; FormatName: String=''; Default: Boolean=False): Boolean; function ReadString(Index: TAppSettingIndex; FormatName: String=''; Default: String=''): String; overload; function ReadString(ValueName: String): String; overload; procedure WriteInt(Index: TAppSettingIndex; Value: Integer; FormatName: String=''); procedure WriteBool(Index: TAppSettingIndex; Value: Boolean; FormatName: String=''); procedure WriteString(Index: TAppSettingIndex; Value: String; FormatName: String=''); overload; procedure WriteString(ValueName, Value: String); overload; function GetDefaultInt(Index: TAppSettingIndex): Integer; function GetDefaultBool(Index: TAppSettingIndex): Boolean; function GetDefaultString(Index: TAppSettingIndex): String; function GetValueName(Index: TAppSettingIndex): String; function GetValueNames: TStringList; function GetKeyNames: TStringList; function GetSessionNames(ParentPath: String; var Folders: TStringList): TStringList; procedure GetSessionPaths(ParentPath: String; var Sessions: TStringList); function DeleteValue(Index: TAppSettingIndex; FormatName: String=''): Boolean; overload; function DeleteValue(ValueName: String): Boolean; overload; procedure DeleteCurrentKey; procedure MoveCurrentKey(TargetPath: String); function ValueExists(Index: TAppSettingIndex): Boolean; function SessionPathExists(SessionPath: String): Boolean; function IsEmptyKey: Boolean; procedure ResetPath; property SessionPath: String read FSessionPath write SetSessionPath; property PortableMode: Boolean read FPortableMode; property Writes: Integer read FWrites; procedure ImportSettings(Filename: String); procedure ExportSettings(Filename: String); overload; procedure ExportSettings; overload; end; {$I const.inc} function implodestr(seperator: String; a: TStrings) :String; function Explode(Separator, Text: String) :TStringList; procedure ExplodeQuotedList(Text: String; var List: TStringList); function sstr(str: String; len: Integer) : String; function encrypt(str: String): String; function decrypt(str: String): String; function HTMLSpecialChars(str: String): String; function BestTableName(Data: TDBQuery): String; function EncodeURLParam(const Value: String): String; procedure StreamWrite(S: TStream; Text: String = ''); function _GetFileSize(Filename: String): Int64; function MakeInt(Str: String) : Int64; function MakeFloat(Str: String): Extended; function CleanupNumber(Str: String): String; function IsNumeric(Str: String): Boolean; function esc(Text: String; ProcessJokerChars: Boolean=false; DoQuote: Boolean=True): String; function ScanLineBreaks(Text: String): TLineBreaks; function fixNewlines(txt: String): String; function ExtractLiteral(var SQL: String; Prefix: String): String; function GetShellFolder(CSIDL: integer): string; // Common directories function DirnameCommonAppData: String; function DirnameUserAppData: String; function DirnameSnippets: String; function goodfilename( str: String ): String; function ExtractBaseFileName(FileName: String): String; function FormatNumber( str: String; Thousands: Boolean=True): String; Overload; function UnformatNumber(Val: String): String; function FormatNumber( int: Int64; Thousands: Boolean=True): String; Overload; function FormatNumber( flt: Double; decimals: Integer = 0; Thousands: Boolean=True): String; Overload; procedure ShellExec(cmd: String; path: String=''; params: String=''); function getFirstWord(text: String; MustStartWithWordChar: Boolean=True): String; function FormatByteNumber( Bytes: Int64; Decimals: Byte = 1 ): String; Overload; function FormatByteNumber( Bytes: String; Decimals: Byte = 1 ): String; Overload; function FormatTimeNumber(Seconds: Cardinal; DisplaySeconds: Boolean): String; function GetTempDir: String; procedure SaveUnicodeFile(Filename: String; Text: String); procedure OpenTextFile(const Filename: String; out Stream: TFileStream; var Encoding: TEncoding); function DetectEncoding(Stream: TStream): TEncoding; function ReadTextfileChunk(Stream: TFileStream; Encoding: TEncoding; ChunkSize: Int64 = 0): String; function ReadTextfile(Filename: String; Encoding: TEncoding): String; function ReadBinaryFile(Filename: String; MaxBytes: Int64): AnsiString; procedure StreamToClipboard(Text, HTML: TStream; CreateHTMLHeader: Boolean); function WideHexToBin(text: String): AnsiString; function BinToWideHex(bin: AnsiString): String; procedure FixVT(VT: TVirtualStringTree; MultiLineCount: Word=1); function GetTextHeight(Font: TFont): Integer; function ColorAdjustBrightness(Col: TColor; Shift: SmallInt): TColor; function ComposeOrderClause(Cols: TOrderColArray): String; procedure DeInitializeVTNodes(Sender: TBaseVirtualTree); function FindNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode): PVirtualNode; procedure SelectNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode=nil); overload; procedure SelectNode(VT: TVirtualStringTree; Node: PVirtualNode); overload; function GetVTSelection(VT: TVirtualStringTree): TStringList; procedure SetVTSelection(VT: TVirtualStringTree; Captions: TStringList); function GetNextNode(Tree: TVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode; function GetPreviousNode(Tree: TVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode; function DateBackFriendlyCaption(d: TDateTime): String; procedure InheritFont(AFont: TFont); function GetLightness(AColor: TColor): Byte; function ReformatSQL(SQL: String): String; function ParamBlobToStr(lpData: Pointer): String; function ParamStrToBlob(out cbData: DWORD): Pointer; function CheckForSecondInstance: Boolean; function GetParentFormOrFrame(Comp: TWinControl): TWinControl; function KeyPressed(Code: Integer): Boolean; function GeneratePassword(Len: Integer): String; procedure InvalidateVT(VT: TVirtualStringTree; RefreshTag: Integer; ImmediateRepaint: Boolean); function CharAtPos(Str: String; Pos: Integer): Char; function CompareAnyNode(Text1, Text2: String): Integer; function StringListCompareAnythingAsc(List: TStringList; Index1, Index2: Integer): Integer; function StringListCompareAnythingDesc(List: TStringList; Index1, Index2: Integer): Integer; function StringListCompareByValue(List: TStringList; Index1, Index2: Integer): Integer; function GetColumnDefaultType(var Text: String): TColumnDefaultType; function GetImageLinkTimeStamp(const FileName: string): TDateTime; function IsEmpty(Str: String): Boolean; function IsNotEmpty(Str: String): Boolean; function MessageDialog(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer; overload; function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; KeepAskingSetting: TAppSettingIndex=asUnused): Integer; overload; function ErrorDialog(Msg: string): Integer; overload; function ErrorDialog(const Title, Msg: string): Integer; overload; function GetHTMLCharsetByEncoding(Encoding: TEncoding): String; procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectionParameters; var FileNames: TStringList); function f_(const Pattern: string; const Args: array of const): string; function GetOutputFilename(FilenameWithPlaceholders: String; DBObj: TDBObject): String; function GetOutputFilenamePlaceholders: TStringList; function GetSystemImageList: TImageList; function GetSystemImageIndex(Filename: String): Integer; function GetExecutableBits: Byte; procedure Help(Sender: TObject; Anchor: String); function PortOpen(Port: Word): Boolean; function IsValidFilePath(FilePath: String): Boolean; function GetAppWebsite(Secure: Boolean): String; var AppSettings: TAppSettings; MutexHandle: THandle = 0; SystemImageList: TImageList; mtCriticalConfirmation: TMsgDlgType = mtCustom; ConfirmIcon: TIcon; implementation uses main; function WideHexToBin(text: String): AnsiString; var buf: AnsiString; begin buf := AnsiString(text); SetLength(Result, Length(text) div 2); HexToBin(PAnsiChar(buf), @Result[1], Length(Result)); end; function BinToWideHex(bin: AnsiString): String; var buf: AnsiString; begin SetLength(buf, Length(bin) * 2); BinToHex(@bin[1], PAnsiChar(buf), Length(bin)); Result := String(buf); end; {*** Convert a TStringList to a string using a separator-string @todo Look at each caller to see if escaping is necessary. @param string Separator @param a TStringList Containing strings @return string } function implodestr(seperator: String; a: TStrings) :String; var i : Integer; begin Result := ''; for i:=0 to a.Count-1 do begin Result := Result + a[i]; if i < a.Count-1 then Result := Result + seperator; end; end; function Explode(Separator, Text: String): TStringList; var i: Integer; Item: String; begin // Explode a string by separator into a TStringList Result := TStringList.Create; while true do begin i := Pos(Separator, Text); if i = 0 then begin // Last or only segment: Add to list if it's the last. Add also if it's not empty and list is empty. // Do not add if list is empty and text is also empty. if (Result.Count > 0) or (Text <> '') then Result.Add(Text); break; end; Item := Trim(Copy(Text, 1, i-1)); Result.Add(Item); Delete(Text, 1, i-1+Length(Separator)); end; end; {*** Shorten string to length len and append 3 dots @param string String to shorten @param integer Wished Length of string @return string } function sstr(str: String; len: Integer) : String; begin if length(str) > len then begin str := copy(str, 0, len-1); str := str + '…'; end; result := str; end; {*** Password-encryption, used to store session-passwords in registry @param string Text to encrypt @return string Encrypted Text } function encrypt(str: String) : String; var i, salt, nr : integer; h : String; begin randomize(); result := ''; salt := random(9) + 1; for i:=1 to length(str) do begin nr := ord(str[i])+salt; if nr > 255 then nr := nr - 255; h := inttohex(nr,0); if length(h) = 1 then h := '0' + h; result := result + h; end; result := result + inttostr(salt); end; {*** Password-decryption, used to restore session-passwords from registry @param string Text to decrypt @return string Decrypted Text } function decrypt(str: String) : String; var j, salt, nr : integer; begin result := ''; if str = '' then exit; j := 1; salt := StrToIntDef(str[length(str)],0); result := ''; while j < length(str)-1 do begin nr := StrToInt('$' + str[j] + str[j+1]) - salt; if nr < 0 then nr := nr + 255; result := result + chr(nr); inc(j, 2); end; end; function HTMLSpecialChars(str: String) : String; begin // Convert critical HTML-characters to entities. Used in grid export. result := StringReplace(str, '&', '&', [rfReplaceAll]); result := StringReplace(result, '<', '<', [rfReplaceAll]); result := StringReplace(result, '>', '>', [rfReplaceAll]); end; function BestTableName(Data: TDBQuery): String; begin // Get table name from result if possible. Used by GridToXYZ() functions. try Result := Data.TableName; except Result := _('UnknownTable'); end; end; function EncodeURLParam(const Value: String): String; var c: Char; const UnsafeChars: String = '*<>#%"{}|\^[]`?&+;'; begin // Encode critical chars in url parameter Result := ''; for c in Value do begin if (Pos(c, UnsafeChars)>0) or (Ord(c) < 33) or (Ord(c) > 128) then Result := Result + '%'+IntToHex(Ord(c), 2) else Result := Result + c; end; end; {** Write some UTF8 text to a file- or memorystream } procedure StreamWrite(S: TStream; Text: String = ''); var utf8: AnsiString; begin utf8 := Utf8Encode(Text); S.Write(utf8[1], Length(utf8)); end; {*** Return filesize of a given file @param string Filename @return int64 Size in bytes } function _GetFileSize(Filename: String): Int64; var Attr: _WIN32_FILE_ATTRIBUTE_DATA; begin if FileExists(Filename) then begin GetFileAttributesEx(PChar(Filename), GetFileExInfoStandard, @Attr); Result := Int64(Attr.nFileSizeHigh) shl 32 + Int64(Attr.nFileSizeLow); end else Result := -1; end; {*** Convert a string-number to an integer-number @param string String-number @return int64 } function MakeInt(Str: String): Int64; begin // Result has to be of integer type try Result := Trunc(MakeFloat(Str)); except Result := 0; end; end; function CleanupNumber(Str: String): String; var i: Integer; HasDecimalSep: Boolean; begin // Ensure the passed string contains a valid number, which is convertable by StrToFloat afterwards // Return it as string again, as there are callers which need to handle unsigned bigint's somehow - // there is no unsigned 64 bit integer type in Delphi. Result := ''; // Unformatted float coming in? Detect by order of thousand and decimal char if ((Pos(',', Str) > 0) and (Pos(',', Str) < Pos('.', Str))) or ((Pos('.', Str) > 0) and (Pos('.', ReverseString(Str)) <> 4)) then begin Str := StringReplace(Str, '.', '*', [rfReplaceAll]); Str := StringReplace(Str, ',', FormatSettings.ThousandSeparator, [rfReplaceAll]); Str := StringReplace(Str, '*', FormatSettings.DecimalSeparator, [rfReplaceAll]); end; HasDecimalSep := False; for i:=1 to Length(Str) do begin if CharInSet(Str[i], ['0'..'9', FormatSettings.DecimalSeparator]) or ((Str[i] = '-') and (Result='')) then begin // Avoid confusion and AV in StrToFloat() if (FormatSettings.ThousandSeparator = FormatSettings.DecimalSeparator) and (Str[i] = FormatSettings.DecimalSeparator) then continue; // Ensure only 1 decimalseparator is left if (Str[i] = FormatSettings.DecimalSeparator) and HasDecimalSep then continue; if Str[i] = FormatSettings.DecimalSeparator then HasDecimalSep := True; Result := Result + Str[i]; end; end; if (Result = '') or (Result = '-') then Result := '0'; end; function IsNumeric(Str: String): Boolean; begin Result := IntToStr(MakeInt(Str)) = Str; end; {*** Convert a string-number to an floatingpoint-number @param String text representation of a number @return Extended } function MakeFloat(Str: String): Extended; var p_kb, p_mb, p_gb, p_tb, p_pb : Integer; begin // Convert result to a floating point value to ensure // we don't discard decimal digits for the next step Result := StrToFloat(CleanupNumber(Str)); // Detect if the string was previously formatted by FormatByteNumber // and convert it back by multiplying it with its byte unit p_kb := Pos(NAME_KB, Str); p_mb := Pos(NAME_MB, Str); p_gb := Pos(NAME_GB, Str); p_tb := Pos(NAME_TB, Str); p_pb := Pos(NAME_PB, Str); if (p_kb > 0) and (p_kb = Length(Str)-Length(NAME_KB)+1) then Result := Result * SIZE_KB else if (p_mb > 0) and (p_mb = Length(Str)-Length(NAME_MB)+1) then Result := Result * SIZE_MB else if (p_gb > 0) and (p_gb = Length(Str)-Length(NAME_GB)+1) then Result := Result * SIZE_GB else if (p_tb > 0) and (p_tb = Length(Str)-Length(NAME_TB)+1) then Result := Result * SIZE_TB else if (p_pb > 0) and (p_pb = Length(Str)-Length(NAME_PB)+1) then Result := Result * SIZE_PB; end; function esc(Text: String; ProcessJokerChars: Boolean=false; DoQuote: Boolean=True): String; begin Result := MainForm.ActiveConnection.EscapeString(Text, ProcessJokerChars, DoQuote); end; {*** SynEdit removes all newlines and semi-randomly decides a new newline format to use for any text edited. See also: Delphi's incomplete implementation of TTextLineBreakStyle in System.pas @param string Text to test @return TLineBreaks } function ScanLineBreaks(Text: String): TLineBreaks; var i: integer; c: Char; procedure SetResult(Style: TLineBreaks); begin // Note: Prefer "(foo <> a) and (foo <> b)" over "not (foo in [a, b])" in excessive loops // for performance reasons - there is or was a Delphi bug leaving those inline SETs in memory // after usage. Unfortunately can't remember which bug id it was and if it still exists. if (Result <> lbsNone) and (Result <> Style) then Result := lbsMixed else Result := Style; end; begin Result := lbsNone; if length(Text) = 0 then exit; i := 1; repeat c := Text[i]; if c = #13 then begin if (i < length(Text)) and (Text[i+1] = #10) then begin Inc(i); SetResult(lbsWindows); end else SetResult(lbsMac); end else if c = LB_UNIX then SetResult(lbsUnix) else if c = LB_WIDE then SetResult(lbsWide); i := i + 1; // No need to do more checks after detecting mixed style if Result = lbsMixed then break; until i > length(Text); end; {*** Unify CR's and LF's to CRLF @param string Text to fix @return string } function fixNewlines(txt: String): String; begin txt := StringReplace(txt, CRLF, #10, [rfReplaceAll]); txt := StringReplace(txt, #13, #10, [rfReplaceAll]); txt := StringReplace(txt, #10, CRLF, [rfReplaceAll]); result := txt; end; function ExtractLiteral(var SQL: String; Prefix: String): String; var i, LitStart: Integer; InLiteral: Boolean; rx: TRegExpr; begin // Return comment from SQL and remove it from the original string // Single quotes are escaped by a second single quote Result := ''; rx := TRegExpr.Create; if Prefix.IsEmpty then rx.Expression := '^\s*''' else rx.Expression := '^\s*'+QuoteRegExprMetaChars(Prefix)+'\s+'''; rx.ModifierI := True; if rx.Exec(SQL) then begin LitStart := rx.MatchLen[0]+1; InLiteral := True; for i:=LitStart to Length(SQL) do begin if SQL[i] = '''' then InLiteral := not InLiteral else if not InLiteral then break; end; Result := Copy(SQL, LitStart, i-LitStart-1); Result := StringReplace(Result, '''''', '''', [rfReplaceAll]); Delete(SQL, 1, i); end; rx.Free; end; {*** Get the path of a Windows(r)-shellfolder, specified by an integer or a constant @param integer Number or constant @return string Path } function GetShellFolder(CSIDL: integer): string; var pidl : PItemIdList; FolderPath : string; SystemFolder : Integer; Malloc : IMalloc; begin Malloc := nil; FolderPath := ''; SHGetMalloc(Malloc); if Malloc = nil then begin Result := FolderPath; Exit; end; try SystemFolder := CSIDL; if SUCCEEDED(SHGetSpecialFolderLocation(0, SystemFolder, pidl)) then begin SetLength(FolderPath, max_path); if SHGetPathFromIDList(pidl, PChar(FolderPath)) then begin SetLength(FolderPath, length(PChar(FolderPath))); end; end; Result := FolderPath; finally Malloc.Free(pidl); end; end; function DirnameCommonAppData: String; begin // "All users" folder for HeidiSQL's data (All Users\Application Data) Result := GetShellFolder(CSIDL_COMMON_APPDATA) + '\' + APPNAME + '\'; end; function DirnameUserAppData: String; begin // User folder for HeidiSQL's data (\Application Data) Result := GetShellFolder(CSIDL_APPDATA) + '\' + APPNAME + '\'; end; function DirnameSnippets: String; begin // Folder for snippets Result := IncludeTrailingBackslash(AppSettings.ReadString(asCustomSnippetsDirectory)); end; {*** Remove special characters from a filename @param string Filename @return string } function goodfilename( str: String ): String; var c : Char; begin result := str; for c in ['\', '/', ':', '*', '?', '"', '<', '>', '|'] do result := StringReplace( result, c, '_', [rfReplaceAll] ); end; function ExtractBaseFileName(FileName: String): String; var Ext: String; begin // Extract file name without path and file extension FileName := ExtractFileName(FileName); Ext := ExtractFileExt(FileName); Result := Copy(FileName, 1, Length(FileName)-Length(Ext)); end; {** Unformat a formatted integer or float. Used for CSV export and composing WHERE clauses for grid editing. } function UnformatNumber(Val: String): String; var i: Integer; HasDecim: Boolean; c: Char; const Numbers = ['0'..'9']; begin Result := ''; HasDecim := False; for i:=1 to Length(Val) do begin c := Val[i]; if (c = '-') and (i = 1) then Result := Result + c else if CharInSet(c, Numbers) then begin if (c = '0') and (Result = '') then // remove zeropadding else Result := Result + c end else if (c = FormatSettings.DecimalSeparator) and (not HasDecim) then begin if Result = '' then Result := '0'; Result := Result + '.'; HasDecim := True; end else if c <> FormatSettings.ThousandSeparator then break; end; if Result = '' then Result := '0'; end; {*** Return a formatted integer or float from a string @param string Text containing a number @return string } function FormatNumber(str: String; Thousands: Boolean=True): String; Overload; var i, p, Left: Integer; begin Result := StringReplace(str, '.', FormatSettings.DecimalSeparator, [rfReplaceAll]); if Thousands then begin // Do not add thousand separators to zerofilled numbers if ((Length(Result) >= 1) and (Result[1] = '0')) or ((Length(Result) >= 2) and (Result[1] = '-') and (Result[2] = '0')) then Exit; p := Pos(FormatSettings.DecimalSeparator, Result); if p = 0 then p := Length(Result)+1; Left := 2; if (Length(Result) >= 1) and (Result[1] = '-') then Left := 3; if p > 0 then for i:=p-1 downto Left do begin if (p-i) mod 3 = 0 then Insert(FormatSettings.ThousandSeparator, Result, i); end; end; end; {*** Return a formatted number from an integer @param int64 Number to format @return string } function FormatNumber(int: Int64; Thousands: Boolean=True): String; Overload; begin result := FormatNumber(IntToStr(int), Thousands); end; {*** Return a formatted number from a float This function is called by two overloaded functions @param double Number to format @param integer Number of decimals @return string } function FormatNumber(flt: Double; decimals: Integer = 0; Thousands: Boolean=True): String; Overload; begin Result := Format('%10.'+IntToStr(decimals)+'f', [flt]); Result := Trim(Result); Result := FormatNumber(Result, Thousands); end; {*** Open URL or execute system command @param string Command or URL to execute @param string Working directory, only usefull is first param is a system command } procedure ShellExec(cmd: String; path: String=''; params: String=''); var Msg: String; begin Msg := 'Executing shell command: "'+cmd+'"'; if not path.IsEmpty then Msg := Msg + ' path: "'+path+'"'; if not params.IsEmpty then Msg := Msg + ' params: "'+params+'"'; MainForm.LogSQL(Msg, lcDebug); ShellExecute(0, 'open', PChar(cmd), PChar(params), PChar(path), SW_SHOWNORMAL); end; {*** Returns first word of a given text @param string Given text @return string First word-boundary } function getFirstWord(text: String; MustStartWithWordChar: Boolean=True): String; var i : Integer; wordChars, wordCharsFirst : TSysCharSet; begin result := ''; text := trim( text ); // First char in word must not be numerical. Fixes queries like // /*!40000 SHOW ENGINES */ to be recognized as "result"-queries // while not breaking getFirstWord in situations where the second // or later char can be a number (fx the collation in createdatabase). wordChars := ['a'..'z', 'A'..'Z', '0'..'9', '_', '-']; if MustStartWithWordChar then wordCharsFirst := wordChars - ['0'..'9'] else wordCharsFirst := wordChars; i := 1; // Find beginning of the first word, ignoring non-alphanumeric chars at the very start // @see bug #1692828 while i < Length(text) do begin if CharInSet(text[i], wordCharsFirst) then begin // Found beginning of word! break; end; if i = Length(text)-1 then begin // Give up in the very last loop, reset counter // and break. We can't find the start of a word i := 1; break; end; inc(i); end; // Add chars as long as they're alpha-numeric while i <= Length(text) do begin if ((result = '') and CharInSet(text[i], wordCharsFirst)) or CharInSet(text[i], wordChars) then begin result := result + text[i]; end else begin // Stop here because we found a non-alphanumeric char. // This applies to all different whitespaces, brackets, commas etc. break; end; inc(i); end; end; {** Format a filesize to automatically use the best fitting expression 16 100 000 Bytes -> 16,1 MB 4 500 Bytes -> 4,5 KB @param Int64 Number of Bytes @param Byte Decimals to display when bytes is bigger than 1M } function FormatByteNumber( Bytes: Int64; Decimals: Byte = 1 ): String; Overload; begin if Bytes >= FSIZE_PB then Result := FormatNumber( Bytes / SIZE_PB, Decimals ) + NAME_PB else if Bytes >= FSIZE_TB then Result := FormatNumber( Bytes / SIZE_TB, Decimals ) + NAME_TB else if Bytes >= FSIZE_GB then Result := FormatNumber( Bytes / SIZE_GB, Decimals ) + NAME_GB else if Bytes >= FSIZE_MB then Result := FormatNumber( Bytes / SIZE_MB, Decimals ) + NAME_MB else if Bytes >= FSIZE_KB then Result := FormatNumber( Bytes / SIZE_KB, Decimals ) + NAME_KB else Result := FormatNumber( Bytes ) + NAME_BYTES end; {** An overloaded function of the previous one which can take a string as input } function FormatByteNumber( Bytes: String; Decimals: Byte = 1 ): String; Overload; begin Result := FormatByteNumber( MakeInt(Bytes), Decimals ); end; {** Format a number of seconds to a human readable time format @param Cardinal Number of seconds @result String 12:34:56 } function FormatTimeNumber(Seconds: Cardinal; DisplaySeconds: Boolean): String; var d, h, m, s : Integer; begin s := Seconds; d := s div (60*60*24); s := s mod (60*60*24); h := s div (60*60); s := s mod (60*60); m := s div 60; s := s mod 60; if d > 0 then begin if DisplaySeconds then Result := Format('%d '+_('days')+', %.2d:%.2d:%.2d', [d, h, m, s]) else Result := Format('%d '+_('days')+', %.2d:%.2d h', [d, h, m]); end else begin if DisplaySeconds then Result := Format('%.2d:%.2d:%.2d', [h, m, s]) else Result := Format('%.2d:%.2d h', [h, m]) end; end; function GetTempDir: String; var TempPath: array[0..MAX_PATH] of Char; begin GetTempPath(MAX_PATH, PChar(@TempPath)); Result := StrPas(TempPath); end; {** Save a textfile with unicode } procedure SaveUnicodeFile(Filename: String; Text: String); var f: TFileStream; begin f := TFileStream.Create(Filename, fmCreate or fmOpenWrite); StreamWrite(f, Text); f.Free; end; procedure OpenTextFile(const Filename: String; out Stream: TFileStream; var Encoding: TEncoding); var Header: TBytes; BomLen: Integer; begin // Open a textfile and return a stream. Detect its encoding if not passed by the caller Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone); if Encoding = nil then Encoding := DetectEncoding(Stream); // If the file contains a BOM, advance the stream's position BomLen := 0; if Length(Encoding.GetPreamble) > 0 then begin SetLength(Header, Length(Encoding.GetPreamble)); Stream.ReadBuffer(Pointer(Header)^, Length(Header)); if CompareMem(Header, Encoding.GetPreamble, SizeOf(Header)) then BomLen := Length(Encoding.GetPreamble); end; Stream.Position := BomLen; end; {** Detect stream's content encoding by examing first 100k bytes (MaxBufferSize). Result can be: UTF-16 BE with BOM UTF-16 LE with BOM UTF-8 with or without BOM ANSI Aimed to work better than WideStrUtils.IsUTF8String() which didn't work in any test case here. @see http://en.wikipedia.org/wiki/Byte_Order_Mark Could also do that with TEncoding.GetBufferEncoding, but that relies on the file having a BOM } function DetectEncoding(Stream: TStream): TEncoding; var ByteOrderMark: Char; BytesRead: Integer; Utf8Test: array[0..2] of AnsiChar; Buffer: array of Byte; BufferSize, i, FoundUTF8Strings: Integer; const UNICODE_BOM = Char($FEFF); UNICODE_BOM_SWAPPED = Char($FFFE); UTF8_BOM = AnsiString(#$EF#$BB#$BF); MinimumCountOfUTF8Strings = 1; MaxBufferSize = 1000000; // 3 trailing bytes are the maximum in valid UTF-8 streams, // so a count of 4 trailing bytes is enough to detect invalid UTF-8 streams function CountOfTrailingBytes: Integer; begin Result := 0; inc(i); while (i < BufferSize) and (Result < 4) do begin if Buffer[i] in [$80..$BF] then inc(Result) else Break; inc(i); end; end; begin // Byte Order Mark ByteOrderMark := #0; if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark)); if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin ByteOrderMark := #0; Stream.Seek(-BytesRead, soFromCurrent); if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar)); if Utf8Test <> UTF8_BOM then Stream.Seek(-BytesRead, soFromCurrent); end; end; end; // Test Byte Order Mark if ByteOrderMark = UNICODE_BOM then Result := TEncoding.Unicode else if ByteOrderMark = UNICODE_BOM_SWAPPED then Result := TEncoding.BigEndianUnicode else if Utf8Test = UTF8_BOM then Result := TEncoding.UTF8 else begin { @note Taken from SynUnicode.pas } { If no BOM was found, check for leading/trailing byte sequences, which are uncommon in usual non UTF-8 encoded text. NOTE: There is no 100% save way to detect UTF-8 streams. The bigger MinimumCountOfUTF8Strings, the lower is the probability of a false positive. On the other hand, a big MinimumCountOfUTF8Strings makes it unlikely to detect files with only little usage of non US-ASCII chars, like usual in European languages. } // if no special characteristics are found it is not UTF-8 Result := TEncoding.Default; // start analysis at actual Stream.Position BufferSize := Min(MaxBufferSize, Stream.Size - Stream.Position); if BufferSize > 0 then begin SetLength(Buffer, BufferSize); Stream.ReadBuffer(Buffer[0], BufferSize); Stream.Seek(-BufferSize, soFromCurrent); FoundUTF8Strings := 0; i := 0; while i < BufferSize do begin if FoundUTF8Strings = MinimumCountOfUTF8Strings then begin Result := TEncoding.UTF8; Break; end; case Buffer[i] of $00..$7F: // skip US-ASCII characters as they could belong to various charsets ; $C2..$DF: if CountOfTrailingBytes = 1 then inc(FoundUTF8Strings) else Break; $E0: begin inc(i); if (i < BufferSize) and (Buffer[i] in [$A0..$BF]) and (CountOfTrailingBytes = 1) then inc(FoundUTF8Strings) else Break; end; $E1..$EC, $EE..$EF: if CountOfTrailingBytes = 2 then inc(FoundUTF8Strings) else Break; $ED: begin inc(i); if (i < BufferSize) and (Buffer[i] in [$80..$9F]) and (CountOfTrailingBytes = 1) then inc(FoundUTF8Strings) else Break; end; $F0: begin inc(i); if (i < BufferSize) and (Buffer[i] in [$90..$BF]) and (CountOfTrailingBytes = 2) then inc(FoundUTF8Strings) else Break; end; $F1..$F3: if CountOfTrailingBytes = 3 then inc(FoundUTF8Strings) else Break; $F4: begin inc(i); if (i < BufferSize) and (Buffer[i] in [$80..$8F]) and (CountOfTrailingBytes = 2) then inc(FoundUTF8Strings) else Break; end; $C0, $C1, $F5..$FF: // invalid UTF-8 bytes Break; $80..$BF: // trailing bytes are consumed when handling leading bytes, // any occurence of "orphaned" trailing bytes is invalid UTF-8 Break; end; inc(i); end; end; end; end; function ReadTextfileChunk(Stream: TFileStream; Encoding: TEncoding; ChunkSize: Int64 = 0): String; const BufferPadding = 4; var DataLeft, StartPosition: Int64; LBuffer: TBytes; i: Integer; begin // Read a chunk or the complete contents out of a textfile, opened by OpenTextFile() if Stream.Size = 0 then begin Result := ''; Exit; end; StartPosition := Stream.Position; DataLeft := Stream.Size - Stream.Position; if (ChunkSize = 0) or (ChunkSize > DataLeft) then ChunkSize := DataLeft; i := 0; while Length(LBuffer) = 0 do begin SetLength(LBuffer, ChunkSize); Stream.ReadBuffer(Pointer(LBuffer)^, ChunkSize); LBuffer := Encoding.Convert(Encoding, TEncoding.Unicode, LBuffer); if Length(LBuffer) = 0 then begin // Now, TEncoding.Convert returns an empty TByte array in files with russion characters // See http://www.heidisql.com/forum.php?t=13044 // Re-read the whole chunk + some more bytes // See: Classes.TStreamReader.FillBuffer // See: https://forums.embarcadero.com/message.jspa?messageID=368526 MainForm.LogSQL(f_('End of file block was cut within some multibyte character, at position %s. Increasing chunk size and retry reading...', [FormatNumber(Stream.Position)]), lcError); Stream.Position := StartPosition; Inc(ChunkSize, BufferPadding); end else // Success, exit loop Break; Inc(i); if i=10 then // Give up Break; end; Result := TEncoding.Unicode.GetString(LBuffer); end; function ReadTextfile(Filename: String; Encoding: TEncoding): String; var Stream: TFileStream; begin // Read a text file into memory OpenTextfile(Filename, Stream, Encoding); Result := ReadTextfileChunk(Stream, Encoding); Stream.Free; end; function ReadBinaryFile(Filename: String; MaxBytes: Int64): AnsiString; var Stream: TFileStream; begin Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone); Stream.Position := 0; if (MaxBytes < 1) or (MaxBytes > Stream.Size) then MaxBytes := Stream.Size; SetLength(Result, MaxBytes); Stream.Read(PAnsiChar(Result)^, Length(Result)); Stream.Free; end; procedure StreamToClipboard(Text, HTML: TStream; CreateHTMLHeader: Boolean); var TextContent, HTMLContent: AnsiString; GlobalMem: HGLOBAL; lp: PChar; ClpLen: Integer; CF_HTML: Word; begin // Copy unicode text to clipboard if Assigned(Text) then begin SetLength(TextContent, Text.Size); Text.Position := 0; Text.Read(PAnsiChar(TextContent)^, Text.Size); Clipboard.AsText := Utf8ToString(TextContent); SetString(TextContent, nil, 0); end; if Assigned(HTML) then begin // If wanted, add a HTML portion, so formatted text can be pasted in WYSIWYG // editors (mostly MS applications). // Note that the content is UTF8 encoded ANSI. Using unicode variables results in raw // text pasted in editors. TODO: Find out why and optimize redundant code away by a loop. OpenClipBoard(0); CF_HTML := RegisterClipboardFormat('HTML Format'); SetLength(HTMLContent, HTML.Size); HTML.Position := 0; HTML.Read(PAnsiChar(HTMLContent)^, HTML.Size); if CreateHTMLHeader then begin HTMLContent := 'Version:0.9' + CRLF + 'StartHTML:000089' + CRLF + 'EndHTML:°°°°°°' + CRLF + 'StartFragment:000089' + CRLF + 'EndFragment:°°°°°°' + CRLF + HTMLContent + CRLF; HTMLContent := AnsiStrings.StringReplace( HTMLContent, '°°°°°°', AnsiStrings.Format('%.6d', [Length(HTMLContent)]), [rfReplaceAll]); end; ClpLen := Length(HTMLContent) + 1; GlobalMem := GlobalAlloc(GMEM_DDESHARE + GMEM_MOVEABLE, ClpLen); lp := GlobalLock(GlobalMem); Move(PAnsiChar(HTMLContent)^, lp[0], ClpLen); SetString(HTMLContent, nil, 0); GlobalUnlock(GlobalMem); SetClipboardData(CF_HTML, GlobalMem); CloseClipboard; end; end; procedure FixVT(VT: TVirtualStringTree; MultiLineCount: Word=1); var SingleLineHeight: Integer; Node: PVirtualNode; begin // Resize hardcoded node height to work with different DPI settings VT.BeginUpdate; SingleLineHeight := GetTextHeight(VT.Font); VT.DefaultNodeHeight := SingleLineHeight * MultiLineCount + 5; // The header needs slightly more height than the normal nodes VT.Header.Height := Trunc(SingleLineHeight * 1.5); // Apply new height to multi line grid nodes Node := VT.GetFirstInitialized; while Assigned(Node) do begin VT.NodeHeight[Node] := VT.DefaultNodeHeight; VT.MultiLine[Node] := MultiLineCount > 1; Node := VT.GetNextInitialized(Node); end; VT.EndUpdate; // Disable hottracking in non-Vista mode, looks ugly in XP, but nice in Vista if (toUseExplorerTheme in VT.TreeOptions.PaintOptions) and (Win32MajorVersion >= 6) then VT.TreeOptions.PaintOptions := VT.TreeOptions.PaintOptions + [toHotTrack] else VT.TreeOptions.PaintOptions := VT.TreeOptions.PaintOptions - [toHotTrack]; VT.OnGetHint := MainForm.AnyGridGetHint; VT.OnScroll := MainForm.AnyGridScroll; VT.OnMouseWheel := MainForm.AnyGridMouseWheel; VT.ShowHint := True; VT.HintMode := hmToolTip; // Apply case insensitive incremental search event if VT.IncrementalSearch <> isNone then VT.OnIncrementalSearch := Mainform.AnyGridIncrementalSearch; VT.OnStartOperation := Mainform.AnyGridStartOperation; VT.OnEndOperation := Mainform.AnyGridEndOperation; end; function GetTextHeight(Font: TFont): Integer; var DC: HDC; SaveFont: HFont; SysMetrics, Metrics: TTextMetric; begin // Code taken from StdCtrls.TCustomEdit.AdjustHeight DC := GetDC(0); GetTextMetrics(DC, SysMetrics); SaveFont := SelectObject(DC, Font.Handle); GetTextMetrics(DC, Metrics); SelectObject(DC, SaveFont); ReleaseDC(0, DC); Result := Metrics.tmHeight; end; function ColorAdjustBrightness(Col: TColor; Shift: SmallInt): TColor; var Lightness: Byte; begin // If base color is bright, make bg color darker (grey), and vice versa, so that // colors work with high contrast mode for accessibility Lightness := GetLightness(Col); if (Lightness < 128) and (Shift < 0) then Shift := Abs(Shift) else if (Lightness > 128) and (Shift > 0) then Shift := 0 - Abs(Shift); Result := ColorAdjustLuma(Col, Shift, true); end; {** Concat all sort options to a ORDER clause } function ComposeOrderClause(Cols: TOrderColArray): String; var i : Integer; sort : String; begin result := ''; for i := 0 to Length(Cols) - 1 do begin if result <> '' then result := result + ', '; if Cols[i].SortDirection = ORDER_ASC then sort := TXT_ASC else sort := TXT_DESC; result := result + MainForm.ActiveConnection.QuoteIdent( Cols[i].ColumnName ) + ' ' + sort; end; end; procedure DeInitializeVTNodes(Sender: TBaseVirtualTree); var Node: PVirtualNode; begin // Forces a VirtualTree to (re-)initialize its nodes. // I wonder why this is not implemented in VirtualTree. Node := Sender.GetFirstInitialized; while Assigned(Node) do begin Node.States := Node.States - [vsInitialized]; Node := Sender.GetNextInitialized(Node); end; end; function FindNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode): PVirtualNode; var Node: PVirtualNode; begin // Helper to find a node by its index Result := nil; if Assigned(ParentNode) then Node := VT.GetFirstChild(ParentNode) else Node := VT.GetFirst; while Assigned(Node) do begin // Note: Grid.RootNodeCount is unfortunately Cardinal, not UInt64. if Node.Index = idx then begin Result := Node; break; end; Node := VT.GetNextSibling(Node); end; end; procedure SelectNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode=nil); overload; var Node: PVirtualNode; begin // Helper to focus and highlight a node by its index Node := FindNode(VT, idx, ParentNode); if Assigned(Node) then SelectNode(VT, Node); end; procedure SelectNode(VT: TVirtualStringTree; Node: PVirtualNode); overload; var OldFocus: PVirtualNode; begin if Node = VT.RootNode then Node := nil; OldFocus := VT.FocusedNode; VT.ClearSelection; VT.FocusedNode := Node; VT.Selected[Node] := True; VT.ScrollIntoView(Node, False); if (OldFocus = Node) and Assigned(VT.OnFocusChanged) then VT.OnFocusChanged(VT, Node, VT.Header.MainColumn); end; function GetVTSelection(VT: TVirtualStringTree): TStringList; var Node: PVirtualNode; InvalidationTag: Integer; begin // Return captions of selected nodes InvalidationTag := vt.Tag; vt.Tag := VTREE_LOADED; Result := TStringList.Create; Node := GetNextNode(VT, nil, true); while Assigned(Node) do begin Result.Add(VT.Text[Node, VT.Header.MainColumn]); Node := GetNextNode(VT, Node, true); end; vt.Tag := InvalidationTag; end; procedure SetVTSelection(VT: TVirtualStringTree; Captions: TStringList); var Node: PVirtualNode; idx: Integer; begin // Restore selected nodes based on captions list Node := GetNextNode(VT, nil, false); while Assigned(Node) do begin idx := Captions.IndexOf(VT.Text[Node, VT.Header.MainColumn]); if idx > -1 then VT.Selected[Node] := True; Node := GetNextNode(VT, Node, false); end; end; function GetNextNode(Tree: TVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode; begin // Get next visible + selected node. Not possible with VTree's own functions. Result := CurrentNode; while True do begin if Selected then begin if not Assigned(Result) then Result := Tree.GetFirstSelected else Result := Tree.GetNextSelected(Result); end else begin if not Assigned(Result) then Result := Tree.GetFirst else Result := Tree.GetNext(Result); end; if (not Assigned(Result)) or Tree.IsVisible[Result] then break; end; end; function GetPreviousNode(Tree: TVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode; begin // Get previous visible + selected node. Result := CurrentNode; while True do begin if Selected then begin if not Assigned(Result) then begin Result := Tree.GetLast; if not Tree.Selected[Result] then Result := Tree.GetPreviousSelected(Result); end else Result := Tree.GetPreviousSelected(Result); end else begin if not Assigned(Result) then Result := Tree.GetLast else Result := Tree.GetPrevious(Result); end; if (not Assigned(Result)) or Tree.IsVisible[Result] then break; end; end; function DateBackFriendlyCaption(d: TDateTime): String; var MonthsAgo, DaysAgo, HoursAgo, MinutesAgo: Int64; begin MonthsAgo := MonthsBetween(Now, d); DaysAgo := DaysBetween(Now, d); HoursAgo := HoursBetween(Now, d); MinutesAgo := MinutesBetween(Now, d); if MonthsAgo = 1 then Result := f_('%s month ago', [FormatNumber(MonthsAgo)]) else if MonthsAgo > 1 then Result := f_('%s months ago', [FormatNumber(MonthsAgo)]) else if DaysAgo = 1 then Result := f_('%s day ago', [FormatNumber(DaysAgo)]) else if DaysAgo > 1 then Result := f_('%s days ago', [FormatNumber(DaysAgo)]) else if HoursAgo = 1 then Result := f_('%s hour ago', [FormatNumber(HoursAgo)]) else if HoursAgo > 1 then Result := f_('%s hours ago', [FormatNumber(HoursAgo)]) else if MinutesAgo = 1 then Result := f_('%s minute ago', [FormatNumber(MinutesAgo)]) else if MinutesAgo > 0 then Result := f_('%s minutes ago', [FormatNumber(MinutesAgo)]) else Result := _('less than a minute ago'); end; procedure ExplodeQuotedList(Text: String; var List: TStringList); var i: Integer; Quote: Char; Opened, Closed: Boolean; Item: String; begin Text := Trim(Text); if Length(Text) > 0 then Quote := Text[1] else Quote := '`'; Opened := False; Closed := True; Item := ''; for i:=1 to Length(Text) do begin if Text[i] = Quote then begin Opened := not Opened; Closed := not Closed; if Closed then begin List.Add(Item); Item := ''; end; Continue; end; if Opened and (not Closed) then Item := Item + Text[i]; end; end; procedure InheritFont(AFont: TFont); var LogFont: TLogFont; GUIFontName: String; begin GUIFontName := AppSettings.ReadString(asGUIFontName); if not GUIFontName.IsEmpty then begin // Apply user specified font AFont.Name := GUIFontName; AFont.Size := AppSettings.ReadInt(asGUIFontSize); end else begin // Apply system font. See issue #3204. // Code taken from http://www.gerixsoft.com/blog/delphi/system-font if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(TLogFont), @LogFont, 0) then begin AFont.Height := LogFont.lfHeight; AFont.Orientation := LogFont.lfOrientation; AFont.Charset := TFontCharset(LogFont.lfCharSet); AFont.Name := PChar(@LogFont.lfFaceName); case LogFont.lfPitchAndFamily and $F of VARIABLE_PITCH: AFont.Pitch := fpVariable; FIXED_PITCH: AFont.Pitch := fpFixed; else AFont.Pitch := fpDefault; end; end; end; end; function GetLightness(AColor: TColor): Byte; var R, G, B: Byte; MaxValue, MinValue: Double; Lightness: Double; begin R := GetRValue(ColorToRGB(AColor)); G := GetGValue(ColorToRGB(AColor)); B := GetBValue(ColorToRGB(AColor)); MaxValue := Max(Max(R,G),B); MinValue := Min(Min(R,G),B); Lightness := (((MaxValue + MinValue) * 240) + 255 ) / 510; Result := Round(Lightness); end; function ReformatSQL(SQL: String): String; var AllKeywords, ImportantKeywords, PairKeywords: TStringList; i, Run, KeywordMaxLen: Integer; IsEsc, IsQuote, InComment, InBigComment, InString, InKeyword, InIdent, LastWasComment: Boolean; c, p: Char; Keyword, PreviousKeyword, TestPair: String; Datatypes: TDBDataTypeArray; const WordChars = ['a'..'z', 'A'..'Z', '0'..'9', '_', '.']; WhiteSpaces = [#9, #10, #13, #32]; begin // Known SQL keywords, get converted to UPPERCASE AllKeywords := TStringList.Create; AllKeywords.Text := MySQLKeywords.Text; for i:=Low(MySQLFunctions) to High(MySQLFunctions) do begin // Leave out operator functions like ">>", and the "X()" function so hex values don't get touched if (MySQLFunctions[i].Declaration <> '') and (MySQLFunctions[i].Name <> 'X') then AllKeywords.Add(MySQLFunctions[i].Name); end; Datatypes := Mainform.ActiveConnection.Datatypes; for i:=Low(Datatypes) to High(Datatypes) do AllKeywords.Add(Datatypes[i].Name); KeywordMaxLen := 0; for i:=0 to AllKeywords.Count-1 do KeywordMaxLen := Max(KeywordMaxLen, Length(AllKeywords[i])); // A subset of the above list, each of them will get a linebreak left to it ImportantKeywords := Explode(',', 'SELECT,FROM,LEFT,RIGHT,STRAIGHT,NATURAL,INNER,JOIN,WHERE,GROUP,ORDER,HAVING,LIMIT,CREATE,DROP,UPDATE,INSERT,REPLACE,TRUNCATE,DELETE'); // Keywords which followers should not get separated into a new line PairKeywords := Explode(',', 'LEFT,RIGHT,STRAIGHT,NATURAL,INNER,ORDER,GROUP'); IsEsc := False; InComment := False; InBigComment := False; LastWasComment := False; InString := False; InIdent := False; Run := 1; Result := ''; SQL := SQL + ' '; SetLength(Result, Length(SQL)*2); Keyword := ''; PreviousKeyword := ''; for i:=1 to Length(SQL) do begin c := SQL[i]; // Current char if i > 1 then p := SQL[i-1] else p := #0; // Previous char // Detection logic - where are we? if c = '\' then IsEsc := not IsEsc else IsEsc := False; IsQuote := (c = '''') or (c = '"'); if c = '`' then InIdent := not InIdent; if (not IsEsc) and IsQuote then InString := not InString; if (c = '#') or ((c = '-') and (p = '-')) then InComment := True; if ((c = #10) or (c = #13)) and InComment then begin LastWasComment := True; InComment := False; end; if (c = '*') and (p = '/') and (not InComment) and (not InString) then InBigComment := True; if (c = '/') and (p = '*') and (not InComment) and (not InString) then InBigComment := False; InKeyword := (not InComment) and (not InBigComment) and (not InString) and (not InIdent) and CharInSet(c, WordChars); // Creation of returning text if InKeyword then begin Keyword := Keyword + c; end else begin if Keyword <> '' then begin if AllKeywords.IndexOf(KeyWord) > -1 then begin while (Run > 1) and CharInSet(Result[Run-1], WhiteSpaces) do Dec(Run); Keyword := UpperCase(Keyword); if Run > 1 then begin // SELECT, WHERE, JOIN etc. get a new line, but don't separate LEFT JOIN with linebreaks if LastWasComment or ((ImportantKeywords.IndexOf(Keyword) > -1) and (PairKeywords.IndexOf(PreviousKeyword) = -1)) then Keyword := CRLF + Keyword else if (Result[Run-1] <> '(') then Keyword := ' ' + Keyword; end; LastWasComment := False; end; PreviousKeyword := Trim(Keyword); Insert(Keyword, Result, Run); Inc(Run, Length(Keyword)); Keyword := ''; end; if (not InComment) and (not InBigComment) and (not InString) and (not InIdent) then begin TestPair := Result[Run-1] + c; if (TestPair = ' ') or (TestPair = '( ') then begin c := Result[Run-1]; Dec(Run); end; if (TestPair = ' )') or (TestPair = ' ,') then Dec(Run); end; Result[Run] := c; Inc(Run); end; end; // Cut overlength SetLength(Result, Run-2); end; { *** TDBObjectEditor } constructor TDBObjectEditor.Create(AOwner: TComponent); begin inherited; // Do not set alClient via DFM! In conjunction with ExplicitXXX properties that // repeatedly breaks the GUI layout when you reload the project Align := alClient; InheritFont(Font); ScaleControls(Screen.PixelsPerInch, FORMS_DPI); end; destructor TDBObjectEditor.Destroy; begin inherited; end; procedure TDBObjectEditor.SetModified(Value: Boolean); begin FModified := Value; end; procedure TDBObjectEditor.Init(Obj: TDBObject); var editName: TWinControl; SynMemo: TSynMemo; popup: TPopupMenu; Item: TMenuItem; i: Integer; begin Mainform.ShowStatusMsg(_('Initializing editor ...')); Mainform.LogSQL(Self.ClassName+'.Init, using object "'+Obj.Name+'"', lcDebug); DBObject := TDBObject.Create(Obj.Connection); DBObject.Assign(Obj); Mainform.UpdateEditorTab; Screen.Cursor := crHourglass; // Enable user to start typing immediately when creating a new object if DBObject.Name = '' then begin editName := FindComponent('editName') as TWinControl; if Assigned(editName) and editName.CanFocus then editName.SetFocus; end; for i:=0 to ComponentCount-1 do begin if not(Components[i] is TSynMemo) then Continue; SynMemo := Components[i] as TSynMemo; if (not Assigned(SynMemo)) or Assigned(SynMemo.PopupMenu) then Continue; popup := TPopupMenu.Create(Self); popup.Images := MainForm.ImageListMain; Item := TMenuItem.Create(popup); Item.Action := MainForm.actCopy; popup.Items.Add(Item); Item := TMenuItem.Create(popup); Item.Action := MainForm.actCut; popup.Items.Add(Item); Item := TMenuItem.Create(popup); Item.Action := MainForm.actPaste; popup.Items.Add(Item); Item := TMenuItem.Create(popup); Item.Action := MainForm.actSelectAll; popup.Items.Add(Item); Item := TMenuItem.Create(popup); Item.Action := MainForm.actSaveSynMemoToTextfile; popup.Items.Add(Item); Item := TMenuItem.Create(popup); Item.Action := MainForm.actToggleComment; popup.Items.Add(Item); SynMemo.PopupMenu := popup; end; end; function TDBObjectEditor.DeInit: TModalResult; var Msg, ObjType: String; begin // Ask for saving modifications Result := mrOk; if Modified then begin ObjType := _(LowerCase(DBObject.ObjType)); if DBObject.Name <> '' then Msg := f_('Save modified %s "%s"?', [ObjType, DBObject.Name]) else Msg := f_('Save new %s?', [ObjType]); Result := MessageDialog(Msg, mtConfirmation, [mbYes, mbNo, mbCancel]); case Result of mrYes: Result := ApplyModifications; mrNo: Modified := False; end; end; end; function TDBObjectEditor.GetDefiners: TStringList; function q(s: String): String; begin Result := DBObject.Connection.QuoteIdent(s); end; begin // For populating combobox items if not Assigned(FDefiners) then begin try FDefiners := DBObject.Connection.GetCol('SELECT CONCAT('+q('User')+', '+esc('@')+', '+q('Host')+') FROM '+ q('mysql')+'.'+q('user')+' WHERE '+q('User')+'!='+esc('')+' ORDER BY '+q('User')+', '+q('Host')); except on E:EDatabaseError do FDefiners := TStringList.Create; end; end; Result := FDefiners; end; // Following code taken from OneInst.pas, http://assarbad.net/de/stuff/!import/nico.old/ // Slightly modified to better integrate that into our code, comments translated from german. // Fetch and separate command line parameters into strings function ParamBlobToStr(lpData: Pointer): String; var pStr: PChar; begin pStr := lpData; Result := string(pStr); end; // Pack current command line parameters function ParamStrToBlob(out cbData: DWORD): Pointer; var cmd: String; begin cmd := Windows.GetCommandLine; cbData := Length(cmd)*2 + 3; Result := PChar(cmd); end; procedure HandleSecondInstance; var Run: DWORD; Now: DWORD; Msg: TMsg; Wnd: HWND; Dat: TCopyDataStruct; begin // MessageBox(0, 'already running', nil, MB_ICONINFORMATION); // Send a message to all main windows (HWND_BROADCAST) with the identical, // previously registered message id. We should only get reply from 0 or 1 // instances. // (Broadcast should only be called with registered message ids!) SendMessage(HWND_BROADCAST, SecondInstMsgId, GetCurrentThreadId, 0); // Waiting for reply by first instance. For those of you which didn't knew: // Threads have message queues too ;o) Wnd := 0; Run := GetTickCount; while True do begin if PeekMessage(Msg, 0, SecondInstMsgId, SecondInstMsgId, PM_NOREMOVE) then begin GetMessage(Msg, 0, SecondInstMsgId, SecondInstMsgId); if Msg.message = SecondInstMsgId then begin Wnd := Msg.wParam; Break; end; end; Now := GetTickCount; if Now < Run then Run := Now; // Avoid overflow, each 48 days. if Now - Run > 5000 then Break; end; if (Wnd <> 0) and IsWindow(Wnd) then begin // As a reply we got a handle to which we now send current parameters Dat.dwData := SecondInstMsgId; Dat.lpData := ParamStrToBlob(Dat.cbData); SendMessage(Wnd, WM_COPYDATA, 0, LPARAM(@Dat)); // Leads to an AV in 64bit mode. See issue #3475: // FreeMemory(Dat.lpData); // Bring first instance to front if not IsWindowVisible(Wnd) then ShowWindow(Wnd, SW_RESTORE); BringWindowToTop(Wnd); SetForegroundWindow(Wnd); end; end; function CheckForSecondInstance: Boolean; var Loop: Integer; MutexName: PChar; begin // Try to create a system wide named kernel object (mutex). And check if that // already exists. // The name of such a mutex must not be longer than MAX_PATH (260) chars and // can contain all chars but not '\' Result := False; MutexName := PChar(APPNAME); for Loop := lstrlen(MutexName) to MAX_PATH - 1 do begin MutexHandle := CreateMutex(nil, False, MutexName); if (MutexHandle = 0) and (GetLastError = INVALID_HANDLE_VALUE) then // Looks like there is already a mutex using this name // Try to solve that by appending an underscore lstrcat(MutexName, '_') else // At least no naming conflict Break; end; case GetLastError of 0: begin // We created the mutex, so this is the first instance end; ERROR_ALREADY_EXISTS: begin // There is already one instance try HandleSecondInstance; finally // Terminating is done in .dpr file, before Application.Initialize Result := True; end; end; else // No clue why we should get here. Oh, maybe Microsoft has changed rules, again. // However, we return false and let the application start end; end; function GetParentFormOrFrame(Comp: TWinControl): TWinControl; begin Result := Comp; while True do begin Result := Result.Parent; // On a windows shutdown, GetParentForm() seems sporadically unable to find the owner form // In that case we would cause an exception when accessing it. Emergency break in that case. // See issue #1462 if (not Assigned(Result)) or (Result is TCustomForm) or (Result is TFrame) then break; end; end; function KeyPressed(Code: Integer): Boolean; var State: TKeyboardState; begin // Checks whether a key is pressed, defined by virtual key code GetKeyboardState(State); Result := (State[Code] and 128) <> 0; end; function GeneratePassword(Len: Integer): String; var i: Integer; CharTable: String; const Consos = 'bcdfghjklmnpqrstvwxyzBCDFGHJKLMNPQRSTVWXYZ'; Vocals = 'aeiouAEIOU'; Numbers = '123456789'; begin // Create a random, mnemonic password SetLength(Result, Len); for i:=1 to Len do begin if Random(4) = 1 then CharTable := Numbers else if i mod 2 = 0 then CharTable := Vocals else CharTable := Consos; Result[i] := CharTable[Random(Length(CharTable)-1)+1]; end; end; procedure InvalidateVT(VT: TVirtualStringTree; RefreshTag: Integer; ImmediateRepaint: Boolean); begin // Avoid AVs in OnDestroy events if not Assigned(VT) then Exit; VT.Tag := RefreshTag; if ImmediateRepaint then VT.Repaint else VT.Invalidate; end; function CharAtPos(Str: String; Pos: Integer): Char; begin // Access char in string without causing access violation if Length(Str) < Pos then Result := #0 else Result := Str[Pos]; end; function CompareAnyNode(Text1, Text2: String): Integer; var Number1, Number2 : Extended; a1, a2, b1, b2: Char; NumberMode: Boolean; const Numbers = ['0'..'9']; begin Result := 0; // Apply different comparisons for numbers and text a1 := CharAtPos(Text1, 1); a2 := CharAtPos(Text1, 2); b1 := CharAtPos(Text2, 1); b2 := CharAtPos(Text2, 2); NumberMode := ((a1='-') and (CharInSet(a2, Numbers)) or CharInSet(a1, Numbers)) and ((b1='-') and (CharInSet(b2, Numbers)) or CharInSet(b1, Numbers)); if NumberMode then begin // Assuming numeric values Number1 := MakeFloat(Text1); Number2 := MakeFloat(Text2); if Number1 > Number2 then Result := 1 else if Number1 = Number2 then Result := 0 else if Number1 < Number2 then Result := -1; end; if (not NumberMode) or (Result=0) then begin // Compare Strings Result := CompareText(Text1, Text2); end; end; function StringListCompareAnythingAsc(List: TStringList; Index1, Index2: Integer): Integer; begin // Sort TStringList items, containing numbers or strings, ascending Result := CompareAnyNode(List[Index1], List[Index2]); end; function StringListCompareAnythingDesc(List: TStringList; Index1, Index2: Integer): Integer; begin // Sort TStringList items, containing numbers or strings, descending Result := CompareAnyNode(List[Index2], List[Index1]); end; function StringListCompareByValue(List: TStringList; Index1, Index2: Integer): Integer; begin // Sort TStringList items which are stored as name=value pairs Result := CompareAnyNode(List.ValueFromIndex[Index2], List.ValueFromIndex[Index1]); end; function GetColumnDefaultType(var Text: String): TColumnDefaultType; begin Result := TColumnDefaultType(MakeInt(Copy(Text, 1, 1))); Text := Copy(Text, 2, Length(Text)-1); end; {** Return compile date/time from passed .exe name Code taken and modified from Michael Puff http://www.michael-puff.de/Programmierung/Delphi/Code-Snippets/GetImageLinkTimeStamp.shtml } function GetImageLinkTimeStamp(const FileName: string): TDateTime; const INVALID_SET_FILE_POINTER = DWORD(-1); BorlandMagicTimeStamp = $2A425E19; // Delphi 4-6 (and above?) FileTime1970: TFileTime = (dwLowDateTime:$D53E8000; dwHighDateTime:$019DB1DE); type PImageSectionHeaders = ^TImageSectionHeaders; TImageSectionHeaders = array [Word] of TImageSectionHeader; type PImageResourceDirectory = ^TImageResourceDirectory; TImageResourceDirectory = packed record Characteristics: DWORD; TimeDateStamp: DWORD; MajorVersion: Word; MinorVersion: Word; NumberOfNamedEntries: Word; NumberOfIdEntries: Word; end; var FileHandle: THandle; BytesRead: DWORD; ImageDosHeader: TImageDosHeader; ImageNtHeaders: TImageNtHeaders; SectionHeaders: PImageSectionHeaders; Section: Word; ResDirRVA: DWORD; ResDirSize: DWORD; ResDirRaw: DWORD; ResDirTable: TImageResourceDirectory; FileTime: TFileTime; TimeStamp: DWord; begin TimeStamp := 0; Result := 0; // Open file for read access FileHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0); if (FileHandle <> INVALID_HANDLE_VALUE) then try // Read MS-DOS header to get the offset of the PE32 header // (not required on WinNT based systems - but mostly available) if not ReadFile(FileHandle, ImageDosHeader, SizeOf(TImageDosHeader), BytesRead, nil) or (BytesRead <> SizeOf(TImageDosHeader)) or (ImageDosHeader.e_magic <> IMAGE_DOS_SIGNATURE) then begin ImageDosHeader._lfanew := 0; end; // Read PE32 header (including optional header if (SetFilePointer(FileHandle, ImageDosHeader._lfanew, nil, FILE_BEGIN) = INVALID_SET_FILE_POINTER) then Exit; if not(ReadFile(FileHandle, ImageNtHeaders, SizeOf(TImageNtHeaders), BytesRead, nil) and (BytesRead = SizeOf(TImageNtHeaders))) then Exit; // Validate PE32 image header if (ImageNtHeaders.Signature <> IMAGE_NT_SIGNATURE) then Exit; // Seconds since 1970 (UTC) TimeStamp := ImageNtHeaders.FileHeader.TimeDateStamp; // Check for Borland's magic value for the link time stamp // (we take the time stamp from the resource directory table) if (ImageNtHeaders.FileHeader.TimeDateStamp = BorlandMagicTimeStamp) then with ImageNtHeaders, FileHeader, OptionalHeader do begin // Validate Optional header if (SizeOfOptionalHeader < IMAGE_SIZEOF_NT_OPTIONAL_HEADER) or (Magic <> IMAGE_NT_OPTIONAL_HDR_MAGIC) then Exit; // Read section headers SectionHeaders := GetMemory(NumberOfSections * SizeOf(TImageSectionHeader)); if Assigned(SectionHeaders) then try if (SetFilePointer(FileHandle, SizeOfOptionalHeader - IMAGE_SIZEOF_NT_OPTIONAL_HEADER, nil, FILE_CURRENT) = INVALID_SET_FILE_POINTER) then Exit; if not(ReadFile(FileHandle, SectionHeaders^, NumberOfSections * SizeOf(TImageSectionHeader), BytesRead, nil) and (BytesRead = NumberOfSections * SizeOf(TImageSectionHeader))) then Exit; // Get RVA and size of the resource directory with DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE] do begin ResDirRVA := VirtualAddress; ResDirSize := Size; end; // Search for section which contains the resource directory ResDirRaw := 0; for Section := 0 to NumberOfSections - 1 do with SectionHeaders[Section] do if (VirtualAddress <= ResDirRVA) and (VirtualAddress + SizeOfRawData >= ResDirRVA + ResDirSize) then begin ResDirRaw := PointerToRawData - (VirtualAddress - ResDirRVA); Break; end; // Resource directory table found? if (ResDirRaw = 0) then Exit; // Read resource directory table if (SetFilePointer(FileHandle, ResDirRaw, nil, FILE_BEGIN) = INVALID_SET_FILE_POINTER) then Exit; if not(ReadFile(FileHandle, ResDirTable, SizeOf(TImageResourceDirectory), BytesRead, nil) and (BytesRead = SizeOf(TImageResourceDirectory))) then Exit; // Convert from DosDateTime to SecondsSince1970 if DosDateTimeToFileTime(HiWord(ResDirTable.TimeDateStamp), LoWord(ResDirTable.TimeDateStamp), FileTime) then begin // FIXME: Borland's linker uses the local system time // of the user who linked the executable image file. // (is that information anywhere?) TimeStamp := (ULARGE_INTEGER(FileTime).QuadPart - ULARGE_INTEGER(FileTime1970).QuadPart) div 10000000; end; finally FreeMemory(SectionHeaders); end; end; finally CloseHandle(FileHandle); end; Result := UnixToDateTime(TimeStamp); end; function IsEmpty(Str: String): Boolean; begin // Alternative version of "Str = ''" Result := Str = ''; end; function IsNotEmpty(Str: String): Boolean; begin // Alternative version of "Str <> ''" Result := Str <> ''; end; function MessageDialog(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): Integer; begin Result := MessageDialog('', Msg, DlgType, Buttons); end; function MessageDialog(const Title, Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; KeepAskingSetting: TAppSettingIndex=asUnused): Integer; var m: String; Dialog: TTaskDialog; Btn: TTaskDialogButtonItem; MsgButton: TMsgDlgBtn; rx: TRegExpr; KeepAskingValue: Boolean; Hotkeys: String; procedure AddButton(BtnCaption: String; BtnResult: TModalResult); var i: Integer; cap: String; begin Btn := TTaskDialogButtonItem(Dialog.Buttons.Add); cap := _(BtnCaption); for i:=1 to Length(cap) do begin // Auto apply hotkey if (Pos(LowerCase(cap[i]), Hotkeys) = 0) and Character.TCharacter.IsLetter(cap[i]) then begin Hotkeys := Hotkeys + LowerCase(cap[i]); Insert('&', cap, i); break; end; end; Btn.Caption := cap; Btn.ModalResult := BtnResult; if (DlgType = mtCriticalConfirmation) and (BtnResult = mrCancel) then Btn.Default := True; end; begin if (Win32MajorVersion >= 6) and StyleServices.Enabled then begin // Use modern task dialog on Vista and above Dialog := TTaskDialog.Create(nil); Dialog.Flags := [tfEnableHyperlinks, tfAllowDialogCancellation]; Dialog.CommonButtons := []; Dialog.OnHyperlinkClicked := MainForm.TaskDialogHyperLinkClicked; // Caption, title and text case DlgType of mtWarning: Dialog.Caption := _('Warning'); mtError: Dialog.Caption := _('Error'); mtInformation: Dialog.Caption := _('Information'); mtConfirmation, mtCustom: Dialog.Caption := _('Confirm'); end; if Title <> Dialog.Caption then Dialog.Title := Title; if MainForm.ActiveConnection <> nil then Dialog.Caption := MainForm.ActiveConnection.Parameters.SessionName + ': ' + Dialog.Caption; rx := TRegExpr.Create; rx.Expression := 'https?\:\/\/\S+'; Dialog.Text := rx.Replace(Msg, '$0', True); rx.Free; // Main icon, and footer link case DlgType of mtWarning: Dialog.MainIcon := tdiWarning; mtError: begin Dialog.MainIcon := tdiError; Dialog.FooterText := ''+_('Find some help on this error')+''; Dialog.FooterIcon := tdiInformation; end; mtInformation: Dialog.MainIcon := tdiInformation; mtConfirmation, mtCustom: begin if not Assigned(ConfirmIcon) then begin ConfirmIcon := TIcon.Create; ConfirmIcon.LoadFromResourceName(hInstance, 'Z_ICONQUESTION'); end; Dialog.Flags := Dialog.Flags + [tfUseHiconMain]; Dialog.CustomMainIcon := ConfirmIcon; end; else Dialog.MainIcon := tdiNone; end; // Add buttons for MsgButton in Buttons do begin case MsgButton of mbYes: AddButton('Yes', mrYes); mbNo: AddButton('No', mrNo); mbOK: AddButton('OK', mrOk); mbCancel: AddButton('Cancel', mrCancel); mbAbort: AddButton('Abort', mrAbort); mbRetry: AddButton('Retry', mrRetry); mbIgnore: AddButton('Ignore', mrIgnore); mbAll: AddButton('All', mrAll); mbNoToAll: AddButton('No to all', mrNoToAll); mbYesToAll: AddButton('Yes to all', mrYesToAll); mbClose: AddButton('Close', mrClose); end; end; // Checkbox, s'il vous plait? KeepAskingValue := True; if KeepAskingSetting <> asUnused then begin if not (mbNo in Buttons) then raise Exception.CreateFmt(_('Missing "No" button in %() call'), ['MessageDialog']); KeepAskingValue := AppSettings.ReadBool(KeepAskingSetting); Dialog.Flags := Dialog.Flags + [tfVerificationFlagChecked]; Dialog.VerificationText := _('Keep asking this question.'); end; // Supress dialog and assume "No" if user disabled this dialog if KeepAskingValue then begin Dialog.Execute; Result := Dialog.ModalResult; if (KeepAskingSetting <> asUnused) and (not (tfVerificationFlagChecked in Dialog.Flags)) then AppSettings.WriteBool(KeepAskingSetting, False); end else Result := mrNo; Dialog.Free; end else begin // Backwards compatible dialog on Windows XP m := Msg; if Title <> '' then m := Title + CRLF + CRLF + m; if KeepAskingSetting <> asUnused then KeepAskingValue := AppSettings.ReadBool(KeepAskingSetting) else KeepAskingValue := True; if KeepAskingValue then Result := MessageDlg(m, DlgType, Buttons, 0) else Result := mrNo; end; end; function ErrorDialog(Msg: string): Integer; begin Result := MessageDialog(Msg, mtError, [mbOK]); end; function ErrorDialog(const Title, Msg: string): Integer; begin Result := MessageDialog(Title, Msg, mtError, [mbOK]); end; function GetHTMLCharsetByEncoding(Encoding: TEncoding): String; begin Result := ''; if Encoding = TEncoding.Default then Result := 'Windows-'+IntToStr(GetACP) else if Encoding.CodePage = 437 then Result := 'ascii' else if Encoding = TEncoding.Unicode then Result := 'utf-16le' else if Encoding = TEncoding.BigEndianUnicode then Result := 'utf-16' else if Encoding = TEncoding.UTF8 then Result := 'utf-8' else if Encoding = TEncoding.UTF7 then Result := 'utf-7'; end; procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectionParameters; var FileNames: TStringList); var rx: TRegExpr; ExeName, SessName, Host, User, Pass, Socket, SSLPrivateKey, SSLCACertificate, SSLCertificate, SSLCipher: String; Port, NetType, WindowsAuth, WantSSL: Integer; AbsentFiles: TStringList; function GetParamValue(ShortName, LongName: String): String; begin // Return one command line switch. Doublequotes are not mandatory. Result := ''; rx.Expression := '\s(\-'+ShortName+'|\-\-'+LongName+')\s*\=?\s*\"([^\-][^\"]*)\"'; if rx.Exec(CommandLine) then Result := rx.Match[2] else begin rx.Expression := '\s(\-'+ShortName+'|\-\-'+LongName+')\s*\=?\s*([^\-]\S*)'; if rx.Exec(CommandLine) then Result := rx.Match[2]; end; end; procedure GetFileNames(Expression: String); begin rx.Expression := Expression; if rx.Exec(CommandLine) then while true do begin if FileExists(rx.Match[1]) then FileNames.Add(rx.Match[1]) else AbsentFiles.Add(rx.Match[1]); // Remove match from input string, so the second call to GetFileNames without quotes // does not detect filenames cut at whitespace Delete(CommandLine, rx.MatchPos[1], rx.MatchLen[1]); if not rx.ExecNext then break; end; end; begin // Parse command line, probably sent by blocked second application instance. // Try to build connection parameters out of it. SessName := ''; FileNames := TStringList.Create; AbsentFiles := TStringList.Create; // Add leading (and trailing) space, so the regular expressions can request a mandantory space // before (and after) each param (and filename) including the first one (and last one) ExeName := ExtractFileName(ParamStr(0)); CommandLine := Copy(CommandLine, Pos(ExeName, CommandLine)+Length(ExeName), Length(CommandLine)); CommandLine := CommandLine + ' '; rx := TRegExpr.Create; SessName := GetParamValue('d', 'description'); if SessName <> '' then begin try ConnectionParams := TConnectionParameters.Create(SessName); except on E:Exception do begin // Session params not found in registry MainForm.LogSQL(E.Message); SessName := ''; end; end; end; // Test if params were passed. If given, override previous values loaded from registry. // Enables the user to log into a session with a different, non-stored user: -dSession -uSomeOther NetType := StrToIntDef(GetParamValue('n', 'nettype'), 0); Host := GetParamValue('h', 'host'); User := GetParamValue('u', 'user'); Pass := GetParamValue('p', 'password'); Socket := GetParamValue('S', 'socket'); Port := StrToIntDef(GetParamValue('P', 'port'), 0); WindowsAuth := StrToIntDef(GetParamValue('W', 'winauth'), -1); WantSSL := StrToIntDef(GetParamValue('ssl', 'ssl'), -1); SSLPrivateKey := GetParamValue('sslprivatekey', 'sslprivatekey'); SSLCACertificate := GetParamValue('sslcacertificate', 'sslcacertificate'); SSLCertificate := GetParamValue('sslcertificate', 'sslcertificate'); SSLCipher := GetParamValue('sslcipher', 'sslcipher'); // Leave out support for startup script, seems reasonable for command line connecting if (Host <> '') or (User <> '') or (Pass <> '') or (Port <> 0) or (Socket <> '') then begin if not Assigned(ConnectionParams) then begin ConnectionParams := TConnectionParameters.Create; ConnectionParams.SessionPath := SessName; end; if NetType <> 0 then ConnectionParams.NetType := TNetType(NetType); try ConnectionParams.GetNetTypeGroup; except ConnectionParams.NetType := ntMySQL_TCPIP; end; if Host <> '' then ConnectionParams.Hostname := Host; if User <> '' then ConnectionParams.Username := User; if Pass <> '' then ConnectionParams.Password := Pass; if Port <> 0 then ConnectionParams.Port := Port; if Socket <> '' then begin ConnectionParams.Hostname := Socket; ConnectionParams.NetType := ntMySQL_NamedPipe; end; if WantSSL in [0,1] then ConnectionParams.WantSSL := Boolean(WantSSL); if SSLPrivateKey <> '' then ConnectionParams.SSLPrivateKey := SSLPrivateKey; if SSLCACertificate <> '' then ConnectionParams.SSLCACertificate := SSLCACertificate; if SSLCertificate <> '' then ConnectionParams.SSLCertificate := SSLCertificate; if SSLCipher <> '' then ConnectionParams.SSLCipher := SSLCipher; if WindowsAuth in [0,1] then ConnectionParams.WindowsAuth := Boolean(WindowsAuth); // Ensure we have a session name to pass to InitConnection if (ConnectionParams.SessionPath = '') and (ConnectionParams.Hostname <> '') then ConnectionParams.SessionPath := ConnectionParams.Hostname; end; // Check for valid filename(s) in parameters. // We support doublequoted and unquoted parameters. GetFileNames('\"([^\"]+\.sql)\"'); GetFileNames('\s([^\s\"]+\.sql)\b'); if AbsentFiles.Count > 0 then ErrorDialog(_('Could not load file(s):'), AbsentFiles.Text); AbsentFiles.Free; rx.Free; end; function f_(const Pattern: string; const Args: array of const): string; begin // Helper for translation, replacement for Format(_()) Result := Format(_(Pattern), Args); end; function GetOutputFilename(FilenameWithPlaceholders: String; DBObj: TDBObject): String; var Arguments: TStringList; Year, Month, Day, Hour, Min, Sec, MSec: Word; i: Integer; begin // Rich format output filename, replace certain markers. See issue #2622 Arguments := TStringList.Create; if Assigned(DBObj) then begin Arguments.Values['session'] := goodfilename(DBObj.Connection.Parameters.SessionName); Arguments.Values['host'] := goodfilename(DBObj.Connection.Parameters.Hostname); Arguments.Values['u'] := goodfilename(DBObj.Connection.Parameters.Username); Arguments.Values['db'] := goodfilename(DBObj.Database); end; Arguments.Values['date'] := goodfilename(DateTimeToStr(Now)); DecodeDateTime(Now, Year, Month, Day, Hour, Min, Sec, MSec); Arguments.Values['d'] := Format('%.2d', [Day]); Arguments.Values['m'] := Format('%.2d', [Month]); Arguments.Values['y'] := Format('%.4d', [Year]); Arguments.Values['h'] := Format('%.2d', [Hour]); Arguments.Values['i'] := Format('%.2d', [Min]); Arguments.Values['s'] := Format('%.2d', [Sec]); Result := FilenameWithPlaceholders; for i:=0 to Arguments.Count-1 do begin Result := StringReplace(Result, '%'+Arguments.Names[i], Arguments.ValueFromIndex[i], [rfReplaceAll]); end; Arguments.Free; end; function GetOutputFilenamePlaceholders: TStringList; begin // Return a list with valid placeholder=>description pairs Result := TStringList.Create; Result.Values['session'] := _('Session name'); Result.Values['host'] := _('Hostname'); Result.Values['u'] := _('Username'); Result.Values['db'] := _('Database'); Result.Values['date'] := _('Date and time'); Result.Values['d'] := _('Day of month'); Result.Values['m'] := _('Month'); Result.Values['y'] := _('Year'); Result.Values['h'] := _('Hour'); Result.Values['i'] := _('Minute'); Result.Values['s'] := _('Second'); end; function GetSystemImageList: TImageList; var Info: TSHFileInfo; ImageListHandle: Cardinal; begin // Create shared imagelist once and use in TPopupMenu and TVirtualTree or whatever if SystemImageList = nil then begin ImageListHandle := SHGetFileInfo('', 0, Info, SizeOf(Info), SHGFI_SYSICONINDEX or SHGFI_SMALLICON); if ImageListHandle <> 0 then begin SystemImageList := TImageList.Create(MainForm); SystemImageList.Handle := ImageListHandle; SystemImageList.ShareImages := true; SystemImageList.DrawingStyle := dsTransparent; end; end; Result := SystemImageList; end; function GetSystemImageIndex(Filename: String): Integer; var Info: TSHFileInfo; begin // Return image index of shared system image list, for a given filename SHGetFileInfo(PChar(Filename), 0, Info, SizeOf(Info), SHGFI_SYSICONINDEX or SHGFI_TYPENAME); Result := Info.iIcon; end; function GetExecutableBits: Byte; const kb32 = 1024 * 32; var ExeFilename: String; Buffer: Array[0..kb32-1] of Byte; // warning: assuming both headers are in there! hFile: DWord; bRead: DWord; bToRead: DWord; pDos: PImageDosHeader; pNt: PImageNtHeaders; begin Result := 32; ExeFilename := ParamStr(0); hFile := CreateFile(pChar(ExeFilename), GENERIC_READ, FILE_SHARE_READ, NIL, OPEN_EXISTING, 0, 0); if hFile <> INVALID_HANDLE_VALUE then try bToRead := GetFileSize(hFile, NIL); if bToRead > kb32 then bToRead := kb32; if not ReadFile(hFile, Buffer, bToRead, bRead, NIL) then Exit; if bRead = bToRead then begin pDos := @Buffer[0]; if pDos.e_magic = IMAGE_DOS_SIGNATURE then begin pNt := PImageNtHeaders(LongInt(pDos) + pDos._lfanew); if pNt.Signature = IMAGE_NT_SIGNATURE then begin if pNt.FileHeader.Machine and IMAGE_FILE_32BIT_MACHINE > 0 then Result := 32 else Result := 64 end; end; end; finally CloseHandle(hFile); end; end; procedure Help(Sender: TObject; Anchor: String); var Place: String; begin // Go to online help page if Sender is TAction then Place := (Sender as TAction).ActionComponent.Name else if Sender is TControl then Place := (Sender as TControl).Name else Place := 'unhandled-'+Sender.ClassName; if IsNotEmpty(Anchor) then Anchor := '#'+Anchor; ShellExec(GetAppWebsite(True)+'help.php?place='+EncodeURLParam(Place)+Anchor); end; function PortOpen(Port: Word): Boolean; var client: sockaddr_in; sock: Integer; ret: Integer; wsdata: WSAData; begin Result := True; ret := WSAStartup($0002, wsdata); if ret<>0 then Exit; try client.sin_family := AF_INET; client.sin_port := htons(Port); client.sin_addr.s_addr := inet_addr(PAnsiChar('127.0.0.1')); sock := socket(AF_INET, SOCK_STREAM, 0); Result := connect(sock, client, SizeOf(client)) <> 0; finally WSACleanup; end; end; function IsValidFilePath(FilePath: String): Boolean; var Pieces: TStringList; i: Integer; begin // Check file path for invalid characters. See http://www.heidisql.com/forum.php?t=20873 Result := True; Pieces := TStringList.Create; SplitRegExpr('[\\\/]', FilePath, Pieces); for i:=1 to Pieces.Count-1 do begin Result := Result and TPath.HasValidFileNameChars(Pieces[i], False); end; Pieces.Free; end; function GetAppWebsite(Secure: Boolean): String; begin // Get project web url, with or without ssl if Secure then Result := 'https://' + APPDOMAIN + '/' else Result := 'http://' + APPDOMAIN + '/'; end; { Threading stuff } constructor TQueryThread.Create(Connection: TDBConnection; Batch: TSQLBatch; TabNumber: Integer); begin inherited Create(False); FConnection := Connection; FAborted := False; FBatch := Batch; FTabNumber := TabNumber; FBatchPosition := 0; FQueryTime := 0; FQueryNetTime := 0; FRowsAffected := 0; FRowsFound := 0; FWarningCount := 0; FErrorMessage := ''; FBatchInOneGo := MainForm.actBatchInOneGo.Checked; FStopOnErrors := MainForm.actQueryStopOnErrors.Checked; FreeOnTerminate := True; Priority := tpNormal; end; procedure TQueryThread.Execute; var SQL: String; i, BatchStartOffset, ResultCount: Integer; PacketSize, MaxAllowedPacket: Int64; DoStoreResult, ErrorAborted: Boolean; begin inherited; MaxAllowedPacket := 0; i := 0; ResultCount := 0; ErrorAborted := False; while i < FBatch.Count do begin SQL := ''; if not FBatchInOneGo then begin SQL := FBatch[i].SQL; Inc(i); end else begin // Concat queries up to a size of max_allowed_packet if MaxAllowedPacket = 0 then begin FConnection.LockedByThread := Self; MaxAllowedPacket := FConnection.MaxAllowedPacket; FConnection.LockedByThread := nil; // TODO: Log('Detected maximum allowed packet size: '+FormatByteNumber(MaxAllowedPacket), lcDebug); end; BatchStartOffset := FBatch[i].LeftOffset; while i < FBatch.Count do begin PacketSize := FBatch[i].RightOffset - BatchStartOffset + ((i-FBatchPosition) * 20); if (PacketSize >= MaxAllowedPacket) and (SQL <> '') then begin // TODO: Log('Limiting batch packet size to '+FormatByteNumber(Length(SQL))+' with '+FormatNumber(i-FUserQueryOffset)+' queries.', lcDebug); break; end; SQL := SQL + FBatch[i].SQL + ';'; Inc(i); end; FQueriesInPacket := i - FBatchPosition; end; Synchronize(BeforeQuery); try FConnection.LockedByThread := Self; DoStoreResult := ResultCount < AppSettings.ReadInt(asMaxQueryResults); FConnection.Query(SQL, DoStoreResult, lcUserFiredSQL); Inc(ResultCount, FConnection.ResultCount); FBatchPosition := i; Inc(FQueryTime, FConnection.LastQueryDuration); Inc(FQueryNetTime, FConnection.LastQueryNetworkDuration); Inc(FRowsAffected, FConnection.RowsAffected); Inc(FRowsFound, FConnection.RowsFound); Inc(FWarningCount, FConnection.WarningCount); except on E:EDatabaseError do begin if FStopOnErrors or (i = FBatch.Count - 1) then begin FErrorMessage := E.Message; ErrorAborted := True; end; end; end; FConnection.LockedByThread := nil; Synchronize(AfterQuery); // Check if FAborted is set by the main thread, to avoid proceeding the loop in case // FStopOnErrors is set to false if FAborted or ErrorAborted then break; end; Synchronize(BatchFinished); end; procedure TQueryThread.BeforeQuery; begin MainForm.BeforeQueryExecution(Self); end; procedure TQueryThread.LogFromOutside(Msg: String; Category: TDBLogCategory); begin FLogMsg := Msg; FLogCategory := Category; Synchronize(Log); end; procedure TQueryThread.Log; begin FConnection.OnLog(FLogMsg, FLogCategory, FConnection); end; procedure TQueryThread.AfterQuery; begin MainForm.AfterQueryExecution(Self); end; procedure TQueryThread.BatchFinished; begin MainForm.FinishedQueryExecution(Self); end; { TSQLSentence } constructor TSQLSentence.Create(Owner: TSQLBatch); begin // Use a back reference to the parent batch object, so we can extract SQL from it FOwner := Owner; end; function TSQLSentence.GetSize: Integer; begin Result := RightOffset - LeftOffset; end; function TSQLSentence.GetSQL: String; begin Result := Copy(FOwner.SQL, LeftOffset, RightOffset-LeftOffset); end; { TSQLBatch } function TSQLBatch.GetSize: Integer; var Query: TSQLSentence; begin // Return overall string length of batch Result := 0; for Query in Self do Inc(Result, Query.Size); end; procedure TSQLBatch.SetSQL(Value: String); var i, AllLen, DelimLen, DelimStart, LastLeftOffset, RightOffset: Integer; c, n, LastStringEncloser: Char; Delim, DelimTest, QueryTest: String; InString, InComment, InBigComment, InEscape: Boolean; Marker: TSQLSentence; rx: TRegExpr; const StringEnclosers = ['"', '''', '`']; NewLines = [#13, #10]; WhiteSpaces = NewLines + [#9, ' ']; begin // Scan SQL batch for delimiters and store a list with start + end offsets FSQL := Value; Clear; AllLen := Length(FSQL); i := 0; LastLeftOffset := 1; Delim := Mainform.Delimiter; InString := False; // Loop in "enclosed string" or `identifier` InComment := False; // Loop in one-line comment (# or --) InBigComment := False; // Loop in /* multi-line */ or /*! condictional comment */ InEscape := False; // Previous char was backslash LastStringEncloser := #0; DelimLen := Length(Delim); rx := TRegExpr.Create; rx.Expression := '^\s*DELIMITER\s+(\S+)'; rx.ModifierG := True; rx.ModifierI := True; rx.ModifierM := False; while i < AllLen do begin Inc(i); // Current and next char c := FSQL[i]; if i < AllLen then n := FSQL[i+1] else n := #0; // Check for comment syntax and for enclosed literals, so a query delimiter can be ignored if (not InComment) and (not InBigComment) and (not InString) and ((c + n = '--') or (c = '#')) then InComment := True; if (not InComment) and (not InBigComment) and (not InString) and (c + n = '/*') then InBigComment := True; if InBigComment and (not InComment) and (not InString) and (c + n = '*/') then InBigComment := False; if (not InEscape) and (not InComment) and (not InBigComment) and CharInSet(c, StringEnclosers) then begin if (not InString) or (InString and (c = LastStringEncloser)) then begin InString := not InString; LastStringEncloser := c; end; end; if (CharInSet(c, NewLines) and (not CharInSet(n, NewLines))) or (i = 1) then begin if i > 1 then InComment := False; if (not InString) and (not InBigComment) and rx.Exec(copy(FSQL, i, 100)) then begin Delim := rx.Match[1]; DelimLen := rx.MatchLen[1]; Inc(i, rx.MatchLen[0]); LastLeftOffset := i; continue; end; end; if not InEscape then InEscape := c = '\' else InEscape := False; // Prepare delimiter test string if (not InComment) and (not InString) and (not InBigComment) then begin DelimStart := Max(1, i+1-DelimLen); DelimTest := Copy(FSQL, DelimStart, i-Max(i-DelimLen, 0)); end else DelimTest := ''; // End of query or batch reached. Add query markers to result list if sentence is not empty. if (DelimTest = Delim) or (i = AllLen) then begin RightOffset := i+1; if DelimTest = Delim then Dec(RightOffset, DelimLen); QueryTest := Trim(Copy(FSQL, LastLeftOffset, RightOffset-LastLeftOffset)); if (QueryTest <> '') and (QueryTest <> Delim) then begin Marker := TSQLSentence.Create(Self); while CharInSet(FSQL[LastLeftOffset], WhiteSpaces) do Inc(LastLeftOffset); Marker.LeftOffset := LastLeftOffset; Marker.RightOffset := RightOffset; Add(Marker); LastLeftOffset := i+1; end; end; end; end; { THttpDownload } constructor THttpDownload.Create(Owner: TComponent); begin FBytesRead := -1; FContentLength := -1; FOwner := Owner; FTimeOut := 10; end; procedure THttpDownload.SendRequest(Filename: String); var NetHandle: HINTERNET; UrlHandle: HINTERNET; Buffer: array[1..4096] of Byte; Head: array[1..1024] of Char; BytesInChunk, HeadSize, Reserved, TimeOutSeconds: Cardinal; LocalFile: File; DoStore: Boolean; UserAgent, OS: String; HttpStatus: Integer; begin DoStore := False; if MainForm.IsWine then OS := 'Linux/Wine' else OS := 'Windows NT '+IntToStr(Win32MajorVersion)+'.'+IntToStr(Win32MinorVersion); UserAgent := APPNAME+'/'+MainForm.AppVersion+' ('+OS+'; '+ExtractFilename(Application.ExeName)+'; '+FOwner.Name+')'; NetHandle := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); // Do not let the user wait 30s TimeOutSeconds := FTimeOut * 1000; InternetSetOption(NetHandle, INTERNET_OPTION_CONNECT_TIMEOUT, @TimeOutSeconds, SizeOf(TimeOutSeconds)); UrlHandle := nil; try UrlHandle := InternetOpenURL(NetHandle, PChar(FURL), nil, 0, INTERNET_FLAG_RELOAD, 0); if not Assigned(UrlHandle) then raise Exception.CreateFmt(_('Could not open URL: %s'), [FURL]); // Detect content length HeadSize := SizeOf(Head); Reserved := 0; if HttpQueryInfo(UrlHandle, HTTP_QUERY_CONTENT_LENGTH, @Head, HeadSize, Reserved) then FContentLength := StrToIntDef(Head, -1) else raise Exception.CreateFmt(_('Server did not send required "Content-Length" header: %s'), [FURL]); // Check if we got HTTP status 200 HeadSize := SizeOf(Head); Reserved := 0; if HttpQueryInfo(UrlHandle, HTTP_QUERY_STATUS_CODE, @Head, HeadSize, Reserved) then begin HttpStatus := StrToIntDef(Head, -1); if HttpStatus <> 200 then raise Exception.CreateFmt(_('Got HTTP status %d from %s'), [HttpStatus, FURL]); end; // Create local file if Filename <> '' then begin AssignFile(LocalFile, FileName); Rewrite(LocalFile, 1); DoStore := True; end; // Stream contents while true do begin InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesInChunk); if DoStore then BlockWrite(LocalFile, Buffer, BytesInChunk); Inc(FBytesRead, BytesInChunk); if Assigned(FOnProgress) then FOnProgress(Self); if BytesInChunk = 0 then break; end; finally if DoStore then CloseFile(LocalFile); if Assigned(UrlHandle) then InternetCloseHandle(UrlHandle); if Assigned(NetHandle) then InternetCloseHandle(NetHandle); end; end; { TAppSettings } constructor TAppSettings.Create; var rx: TRegExpr; i: Integer; DefaultSnippetsDirectory: String; begin inherited; FRegistry := TRegistry.Create; FReads := 0; FWrites := 0; // Use filename from command line. If not given, use file in directory of executable. rx := TRegExpr.Create; rx.Expression := '^\-\-?psettings\=(.+)$'; for i:=1 to ParamCount do begin if rx.Exec(ParamStr(i)) then begin FSettingsFile := rx.Match[1]; break; end; end; if FSettingsFile = '' then FSettingsFile := ExtractFilePath(ParamStr(0)) + 'portable_settings.txt'; if FileExists(FSettingsFile) then begin FPortableMode := True; FBasePath := '\Software\' + APPNAME + ' Portable '+IntToStr(GetCurrentProcessId)+'\'; try ImportSettings(FSettingsFile); except on E:Exception do ErrorDialog(E.Message); end; end else begin FPortableMode := False; FBasePath := '\Software\' + APPNAME + '\'; FSettingsFile := ''; end; PrepareRegistry; InitSetting(asHiddenColumns, 'HiddenColumns', 0, False, '', True); InitSetting(asFilter, 'Filter', 0, False, '', True); InitSetting(asSort, 'Sort', 0, False, '', True); InitSetting(asDisplayedColumnsSorted, 'DisplayedColumnsSorted', 0, False); InitSetting(asLastSessions, 'LastSessions', 0, False, ''); InitSetting(asLastActiveSession, 'LastActiveSession', 0, False, ''); InitSetting(asAutoReconnect, 'AutoReconnect', 0, False); InitSetting(asRestoreLastUsedDB, 'RestoreLastUsedDB', 0, True); InitSetting(asLastUsedDB, 'lastUsedDB', 0, False, '', True); InitSetting(asTreeBackground, 'TreeBackground', clNone, False, '', True); if Screen.Fonts.IndexOf('Consolas') > -1 then InitSetting(asFontName, 'FontName', 0, False, 'Consolas') else InitSetting(asFontName, 'FontName', 0, False, 'Courier New'); InitSetting(asFontSize, 'FontSize', 9); InitSetting(asTabWidth, 'TabWidth', 3); InitSetting(asDataFontName, 'DataFontName', 0, False, 'Tahoma'); InitSetting(asDataFontSize, 'DataFontSize', 8); InitSetting(asDataLocalNumberFormat, 'DataLocalNumberFormat', 0, True); InitSetting(asHintsOnResultTabs, 'HintsOnResultTabs', 0, True); InitSetting(asLogsqlnum, 'logsqlnum', 300); InitSetting(asLogsqlwidth, 'logsqlwidth', 2000); InitSetting(asSessionLogsDirectory, 'SessionLogsDirectory', 0, False, DirnameUserAppData + 'Sessionlogs\'); InitSetting(asLogHorizontalScrollbar, 'LogHorizontalScrollbar', 0, False); InitSetting(asSQLColActiveLine, 'SQLColActiveLine', 0, False, 'clNone'); InitSetting(asSQLColMatchingBraceForeground, 'SQLColMatchingBraceForeground', 0, False, 'clBlack'); InitSetting(asSQLColMatchingBraceBackground, 'SQLColMatchingBraceBackground', 0, False, 'clAqua'); InitSetting(asMaxColWidth, 'MaxColWidth', 300); InitSetting(asDatagridMaximumRows, 'DatagridMaximumRows', 100000); InitSetting(asDatagridRowsPerStep, 'DatagridRowsPerStep', 1000); InitSetting(asGridRowLineCount, 'GridRowLineCount', 1); InitSetting(asReuseEditorConfiguration, 'ReuseEditorConfiguration', 0, True); InitSetting(asLogToFile, 'LogToFile', 0, False); InitSetting(asMainWinMaximized, 'MainWinMaximized', 0, False); InitSetting(asMainWinLeft, 'MainWinLeft', 100); InitSetting(asMainWinTop, 'MainWinTop', 100); InitSetting(asMainWinWidth, 'MainWinWidth', 950); InitSetting(asMainWinHeight, 'MainWinHeight', 600); InitSetting(asMainWinOnMonitor, 'MainWinOnMonitor', 1); InitSetting(asCoolBandIndex, 'CoolBand%sIndex', 0); InitSetting(asCoolBandBreak, 'CoolBand%sBreak', 0, True); InitSetting(asCoolBandWidth, 'CoolBand%sWidth', 0); InitSetting(asQuerymemoheight, 'querymemoheight', 100); InitSetting(asDbtreewidth, 'dbtreewidth', 270); InitSetting(asDataPreviewHeight, 'DataPreviewHeight', 100); InitSetting(asDataPreviewEnabled, 'DataPreviewEnabled', 0, False); InitSetting(asLogHeight, 'sqloutheight', 80); InitSetting(asQueryhelperswidth, 'queryhelperswidth', 200); InitSetting(asStopOnErrorsInBatchMode, 'StopOnErrorsInBatchMode', 0, True); InitSetting(asWrapLongLines, 'WrapLongLines', 0, False); InitSetting(asDisplayBLOBsAsText, 'DisplayBLOBsAsText', 0, False); InitSetting(asSingleQueries, 'SingleQueries', 0, True); InitSetting(asMemoEditorWidth, 'MemoEditorWidth', 100); InitSetting(asMemoEditorHeight, 'MemoEditorHeight', 100); InitSetting(asMemoEditorWrap, 'MemoEditorWrap', 0, False); InitSetting(asDelimiter, 'Delimiter', 0, False, ';'); InitSetting(asSQLHelpWindowLeft, 'SQLHelp_WindowLeft', 0); InitSetting(asSQLHelpWindowTop, 'SQLHelp_WindowTop', 0); InitSetting(asSQLHelpWindowWidth, 'SQLHelp_WindowWidth', 600); InitSetting(asSQLHelpWindowHeight, 'SQLHelp_WindowHeight', 400); InitSetting(asSQLHelpPnlLeftWidth, 'SQLHelp_PnlLeftWidth', 150); InitSetting(asSQLHelpPnlRightTopHeight, 'SQLHelp_PnlRightTopHeight', 150); InitSetting(asTableEditorTabsHeight, 'TableEditorTabsHeight', 150); InitSetting(asHost, 'Host', 0, False, '127.0.0.1', True); InitSetting(asUser, 'User', 0, False, 'root', True); InitSetting(asPassword, 'Password', 0, False, '', True); InitSetting(asWindowsAuth, 'WindowsAuth', 0, False, '', True); InitSetting(asLoginPrompt, 'LoginPrompt', 0, False, '', True); InitSetting(asPort, 'Port', 0, False, '3306', True); InitSetting(asPlinkExecutable, 'PlinkExecutable', 0, False, ''); InitSetting(asSSHtunnelHost, 'SSHtunnelHost', 0, False, '', True); InitSetting(asSSHtunnelHostPort, 'SSHtunnelHostPort', 22, False, '', True); InitSetting(asSSHtunnelPort, 'SSHtunnelPort', 0, False, '', True); InitSetting(asSSHtunnelUser, 'SSHtunnelUser', 0, False, '', True); InitSetting(asSSHtunnelPassword, 'SSHtunnelPassword', 0, False, '', True); InitSetting(asSSHtunnelTimeout, 'SSHtunnelTimeout', 4, False, '', True); InitSetting(asSSHtunnelPrivateKey, 'SSHtunnelPrivateKey', 0, False, '', True); InitSetting(asSSLActive, 'SSL_Active', 0, False, '', True); InitSetting(asSSLKey, 'SSL_Key', 0, False, '', True); InitSetting(asSSLCert, 'SSL_Cert', 0, False, '', True); InitSetting(asSSLCA, 'SSL_CA', 0, False, '', True); InitSetting(asSSLCipher, 'SSL_Cipher', 0, False, '', True); InitSetting(asNetType, 'NetType', Integer(ntMySQL_TCPIP), False, '', True); InitSetting(asCompressed, 'Compressed', 0, False, '', True); InitSetting(asLocalTimeZone, 'LocalTimeZone', 0, False, '', True); InitSetting(asQueryTimeout, 'QueryTimeout', 30, False, '', True); InitSetting(asKeepAlive, 'KeepAlive', 20, False, '', True); InitSetting(asStartupScriptFilename, 'StartupScriptFilename', 0, False, '', True); InitSetting(asDatabases, 'Databases', 0, False, '', True); InitSetting(asComment, 'Comment', 0, False, '', True); InitSetting(asDatabaseFilter, 'DatabaseFilter', 0, False, ''); InitSetting(asTableFilter, 'TableFilter', 0, False, ''); InitSetting(asExportSQLCreateDatabases, 'ExportSQL_CreateDatabases', 0, False); InitSetting(asExportSQLCreateTables, 'ExportSQL_CreateTables', 0, False); InitSetting(asExportSQLDataHow, 'ExportSQL_DataHow', 0); InitSetting(asExportSQLDataInsertSize, 'ExportSQL_DataInsertSize', 1024); InitSetting(asExportSQLFilenames, 'ExportSQL_Filenames', 0, False, ''); InitSetting(asExportZIPFilenames, 'ExportSQL_ZipFilenames', 0, False, ''); InitSetting(asExportSQLDirectories, 'ExportSQL_Directories', 0, False, ''); InitSetting(asExportSQLDatabase, 'ExportSQL_Database', 0, False, ''); InitSetting(asExportSQLServerDatabase, 'ExportSQL_ServerDatabase', 0, False, ''); InitSetting(asExportSQLOutput, 'ExportSQL_Output', 0); InitSetting(asExportSQLAddComments, 'ExportSQLAddComments', 0, True); InitSetting(asExportSQLRemoveAutoIncrement, 'ExportSQLRemoveAutoIncrement', 0, False); InitSetting(asGridExportOutputCopy, 'GridExportOutputCopy', 0, True); InitSetting(asGridExportOutputFile, 'GridExportOutputFile', 0, False); InitSetting(asGridExportFilename, 'GridExportFilename', 0, False, ''); InitSetting(asGridExportRecentFiles, 'GridExportRecentFiles', 0, False, ''); InitSetting(asGridExportEncoding, 'GridExportEncoding', 4); InitSetting(asGridExportFormat, 'GridExportFormat', 0); InitSetting(asGridExportSelection, 'GridExportSelection', 1); InitSetting(asGridExportColumnNames, 'GridExportColumnNames', 0, True); InitSetting(asGridExportIncludeAutoInc, 'GridExportAutoInc', 0, True); InitSetting(asGridExportIncludeQuery, 'GridExportIncludeQuery', 0, False); InitSetting(asGridExportSeparator, 'GridExportSeparator', 0, False, ';'); InitSetting(asGridExportEncloser, 'GridExportEncloser', 0, False, ''); InitSetting(asGridExportTerminator, 'GridExportTerminator', 0, False, '\r\n'); InitSetting(asGridExportNull, 'GridExportNull', 0, False, '\N'); // Copy to clipboard defaults: InitSetting(asGridExportClpFormat, 'GridExportClpFormat', 0); InitSetting(asGridExportClpColumnNames, 'GridExportClpColumnNames', 0, False); InitSetting(asGridExportClpIncludeAutoInc, 'GridExportClpAutoInc', 0, True); InitSetting(asGridExportClpSeparator, 'GridExportClpSeparator', 0, False, ';'); InitSetting(asGridExportClpEncloser, 'GridExportClpEncloser', 0, False, ''); InitSetting(asGridExportClpTerminator, 'GridExportClpTerminator', 0, False, '\r\n'); InitSetting(asGridExportClpNull, 'GridExportClpNull', 0, False, '\N'); InitSetting(asCSVImportSeparator, 'CSVSeparatorV2', 0, False, ';'); InitSetting(asCSVImportEncloser, 'CSVEncloserV2', 0, False, '"'); InitSetting(asCSVImportTerminator, 'CSVTerminator', 0, False, '\r\n'); InitSetting(asCSVImportFieldEscaper, 'CSVImportFieldEscaperV2', 0, False, '"'); InitSetting(asCSVImportWindowWidth, 'CSVImportWindowWidth', 530); InitSetting(asCSVImportWindowHeight, 'CSVImportWindowHeight', 530); InitSetting(asCSVImportFilename, 'loadfilename', 0, False, ''); InitSetting(asCSVImportFieldsEnclosedOptionally, 'CSVImportFieldsEnclosedOptionallyV2', 0, True); InitSetting(asCSVImportIgnoreLines, 'CSVImportIgnoreLines', 1); InitSetting(asCSVImportLowPriority, 'CSVImportLowPriority', 0, True); InitSetting(asCSVImportLocalNumbers, 'CSVImportLocalNumbers', 0, False); InitSetting(asCSVImportDuplicateHandling, 'CSVImportDuplicateHandling', 2); InitSetting(asCSVImportParseMethod, 'CSVImportParseMethod', 0); InitSetting(asUpdatecheck, 'Updatecheck', 0, False); InitSetting(asUpdatecheckBuilds, 'UpdatecheckBuilds', 0, False); InitSetting(asUpdatecheckInterval, 'UpdatecheckInterval', 3); InitSetting(asUpdatecheckLastrun, 'UpdatecheckLastrun', 0, False, '2000-01-01'); InitSetting(asTableToolsWindowWidth, 'TableTools_WindowWidth', 800); InitSetting(asTableToolsWindowHeight, 'TableTools_WindowHeight', 420); InitSetting(asTableToolsTreeWidth, 'TableTools_TreeWidth', 300); InitSetting(asTableToolsFindText, 'TableTools_FindText', 0, False, ''); InitSetting(asTableToolsDatatype, 'TableTools_Datatype', 0); InitSetting(asTableToolsFindCaseSensitive, 'TableTools_FindCaseSensitive', 0, False); InitSetting(asTableToolsFindMatchType, 'TableToolsFindMatchType', 0); InitSetting(asFileImportWindowWidth, 'FileImport_WindowWidth', 530); InitSetting(asFileImportWindowHeight, 'FileImport_WindowHeight', 530); InitSetting(asEditVarWindowWidth, 'EditVar_WindowWidth', 300); InitSetting(asEditVarWindowHeight, 'EditVar_WindowHeight', 260); InitSetting(asUsermanagerWindowWidth, 'Usermanager_WindowWidth', 500); InitSetting(asUsermanagerWindowHeight, 'Usermanager_WindowHeight', 400); InitSetting(asUsermanagerListWidth, 'Usermanager_ListWidth', 180); InitSetting(asSelectDBOWindowWidth, 'SelectDBO_WindowWidth', 250); InitSetting(asSelectDBOWindowHeight, 'SelectDBO_WindowHeight', 350); InitSetting(asSessionManagerListWidth, 'SessionManager_ListWidth', 220); InitSetting(asSessionManagerWindowWidth, 'SessionManager_WindowWidth', 700); InitSetting(asSessionManagerWindowHeight, 'SessionManager_WindowHeight', 420); InitSetting(asCopyTableWindowHeight, 'CopyTable_WindowHeight', 340); InitSetting(asCopyTableWindowWidth, 'CopyTable_WindowWidth', 380); InitSetting(asCopyTableColumns, 'CopyTable_Columns', 0, True); InitSetting(asCopyTableKeys, 'CopyTable_Keys', 0, True); InitSetting(asCopyTableForeignKeys, 'CopyTable_ForeignKeys', 0, True); InitSetting(asCopyTableData, 'CopyTable_Data', 0, True); InitSetting(asCopyTableRecentFilter, 'CopyTable_RecentFilter_%s', 0, False, ''); InitSetting(asServerVersion, 'ServerVersion', 0, False, '', True); InitSetting(asServerVersionFull, 'ServerVersionFull', 0, False, '', True); InitSetting(asLastConnect, 'LastConnect', 0, False, '2000-01-01', True); InitSetting(asConnectCount, 'ConnectCount', 0, False, '', True); InitSetting(asRefusedCount, 'RefusedCount', 0, False, '', True); InitSetting(asSessionCreated, 'SessionCreated', 0, False, '', True); InitSetting(asDoUsageStatistics, 'DoUsageStatistics', 0, False); InitSetting(asLastUsageStatisticCall, 'LastUsageStatisticCall', 0, False, '2000-01-01'); InitSetting(asDisplayBars, 'DisplayBars', 0, true); InitSetting(asBarColor, 'BarColor', $00BBFFDD); InitSetting(asMySQLBinaries, 'MySQL_Binaries', 0, False, ''); // Default folder for snippets if FPortableMode then DefaultSnippetsDirectory := ExtractFilePath(ParamStr(0)) else DefaultSnippetsDirectory := DirnameCommonAppData; DefaultSnippetsDirectory := DefaultSnippetsDirectory + 'Snippets\'; InitSetting(asCustomSnippetsDirectory, 'CustomSnippetsDirectory', 0, False, DefaultSnippetsDirectory); InitSetting(asPromptSaveFileOnTabClose, 'PromptSaveFileOnTabClose', 0, True); InitSetting(asWarnUnsafeUpdates, 'WarnUnsafeUpdates', 0, True); InitSetting(asCompletionProposal, 'CompletionProposal', 0, True); InitSetting(asCompletionProposalWidth, 'CompletionProposalWidth', 350); InitSetting(asCompletionProposalNbLinesInWindow,'CompletionProposalNbLinesInWindow', 12); InitSetting(asTabsToSpaces, 'TabsToSpaces', 0, False); InitSetting(asFilterPanel, 'FilterPanel', 0, False); InitSetting(asAllowMultipleInstances, 'AllowMultipleInstances', 0, True); InitSetting(asFindDialogSearchHistory, 'FindDialogSearchHistory', 0, False, ''); InitSetting(asFindDialogReplaceHistory, 'FindDialogReplaceHistory', 0, False, ''); InitSetting(asGUIFontName, 'GUIFontName', 0, False, ''); InitSetting(asGUIFontSize, 'GUIFontSize', 8); InitSetting(asMaxQueryResults, 'MaxQueryResults', 10); InitSetting(asLogErrors, 'LogErrors', 0, True); InitSetting(asLogUserSQL, 'LogUserSQL', 0, True); InitSetting(asLogSQL, 'LogSQL', 0, True); InitSetting(asLogInfos, 'LogInfos', 0, True); InitSetting(asLogDebug, 'LogDebug', 0, False); InitSetting(asFieldColorNumeric, 'FieldColor_Numeric', $00FF0000); InitSetting(asFieldColorReal, 'FieldColor_Real', $00FF0048); InitSetting(asFieldColorText, 'FieldColor_Text', $00008000); InitSetting(asFieldColorBinary, 'FieldColor_Binary', $00800080); InitSetting(asFieldColorDatetime, 'FieldColor_Datetime', $00000080); InitSetting(asFieldColorSpatial, 'FieldColor_Spatial', $00808000); InitSetting(asFieldColorOther, 'FieldColor_Other', $00008080); InitSetting(asFieldEditorBinary, 'FieldEditor_Binary', 0, True); InitSetting(asFieldEditorDatetime, 'FieldEditor_Datetime', 0, True); InitSetting(asFieldEditorDatetimePrefill, 'FieldEditor_Datetime_Prefill', 0, True); InitSetting(asFieldEditorEnum, 'FieldEditor_Enum', 0, True); InitSetting(asFieldEditorSet, 'FieldEditor_Set', 0, True); InitSetting(asFieldNullBackground, 'Field_NullBackground', clNone); InitSetting(asRowBackgroundEven, 'RowBackgroundEven', clNone); InitSetting(asRowBackgroundOdd, 'RowBackgroundOdd', clNone); InitSetting(asGroupTreeObjects, 'GroupTreeObjects', 0, False); InitSetting(asDisplayObjectSizeColumn, 'DisplayObjectSizeColumn', 0, True); InitSetting(asActionShortcut1, 'Shortcut1_%s', 0); InitSetting(asActionShortcut2, 'Shortcut2_%s', 0); InitSetting(asHighlighterForeground, 'SQL Attr %s Foreground', 0); InitSetting(asHighlighterBackground, 'SQL Attr %s Background', 0); InitSetting(asHighlighterStyle, 'SQL Attr %s Style', 0); InitSetting(asSQLfile, 'SQLFile%s', 0, False, ''); InitSetting(asListColWidths, 'ColWidths_%s', 0, False, ''); InitSetting(asListColsVisible, 'ColsVisible_%s', 0, False, ''); InitSetting(asListColPositions, 'ColPositions_%s', 0, False, ''); InitSetting(asListColSort, 'ColSort_%s', 0, False, ''); InitSetting(asSessionFolder, 'Folder', 0, False, '', True); InitSetting(asRecentFilter, '%s', 0, False, '', True); InitSetting(asTimestampColumns, 'TimestampColumns', 0, False, '', True); InitSetting(asDateTimeEditorCursorPos, 'DateTimeEditor_CursorPos_Type%s', 0); InitSetting(asAppLanguage, 'Language', 0, False, ''); InitSetting(asAutoExpand, 'AutoExpand', 0, False); InitSetting(asDoubleClickInsertsNodeText, 'DoubleClickInsertsNodeText', 0, True); InitSetting(asForeignDropDown, 'ForeignDropDown', 0, True); InitSetting(asQueryHistoryEnabled, 'QueryHistory', 0, True); InitSetting(asQueryHistoryKeepDays, 'QueryHistoryKeeypDays', 30); InitSetting(asColumnSelectorWidth, 'ColumnSelectorWidth', 200, False, ''); InitSetting(asColumnSelectorHeight, 'ColumnSelectorHeight', 270, False, ''); InitSetting(asDonatedEmail, 'DonatedEmail', 0, False, ''); InitSetting(asFavoriteObjects, 'FavoriteObjects', 0, False, '', True); InitSetting(asFavoriteObjectsOnly, 'FavoriteObjectsOnly', 0, False); InitSetting(asFullTableStatus, 'FullTableStatus', 0, True, '', True); InitSetting(asLineBreakStyle, 'LineBreakStyle', Integer(lbsNone)); InitSetting(asFileDialogEncoding, 'FileDialogEncoding_%s', 0); end; destructor TAppSettings.Destroy; var AllKeys: TStringList; i: Integer; Proc: TProcessEntry32; ProcRuns: Boolean; SnapShot: THandle; rx: TRegExpr; begin // Export settings into textfile in portable mode. if FPortableMode then try ExportSettings(FSettingsFile); FRegistry.CloseKey; FRegistry.DeleteKey(FBasePath); // Remove dead keys from instances which didn't close clean, e.g. because of an AV SnapShot := CreateToolhelp32Snapshot(TH32CS_SnapProcess, 0); Proc.dwSize := Sizeof(Proc); FRegistry.OpenKeyReadOnly('\Software\'); AllKeys := TStringList.Create; FRegistry.GetKeyNames(AllKeys); rx := TRegExpr.Create; rx.Expression := '^' + QuoteRegExprMetaChars(APPNAME) + ' Portable (\d+)$'; for i:=0 to AllKeys.Count-1 do begin if not rx.Exec(AllKeys[i]) then Continue; ProcRuns := False; if Process32First(SnapShot, Proc) then while True do begin ProcRuns := rx.Match[1] = IntToStr(Proc.th32ProcessID); if ProcRuns or (not Process32Next(SnapShot, Proc)) then break; end; if not ProcRuns then FRegistry.DeleteKey(AllKeys[i]); end; FRegistry.CloseKey; CloseHandle(SnapShot); AllKeys.Free; rx.Free; except on E:Exception do // Prefer ShowMessage, see http://www.heidisql.com/forum.php?t=14001 ShowMessage('Error: '+E.Message); end; FRegistry.Free; inherited; end; procedure TAppSettings.InitSetting(Index: TAppSettingIndex; Name: String; DefaultInt: Integer=0; DefaultBool: Boolean=False; DefaultString: String=''; Session: Boolean=False); begin FSettings[Index].Name := Name; FSettings[Index].Session := Session; FSettings[Index].DefaultInt := DefaultInt; FSettings[Index].DefaultBool := DefaultBool; FSettings[Index].DefaultString := DefaultString; FSettings[Index].Synced := False; end; procedure TAppSettings.SetSessionPath(Value: String); begin // Following calls may want to read or write some session specific setting if Value <> FSessionPath then begin FSessionPath := Value; PrepareRegistry; end; end; procedure TAppSettings.ResetPath; begin SessionPath := ''; end; procedure TAppSettings.PrepareRegistry; var Folder: String; begin // Open the wanted registry path Folder := FBasePath; if FSessionPath <> '' then Folder := Folder + REGKEY_SESSIONS + '\' + FSessionPath; if '\'+FRegistry.CurrentPath <> Folder then FRegistry.OpenKey(Folder, True); end; function TAppSettings.GetValueNames: TStringList; begin PrepareRegistry; Result := TStringList.Create; FRegistry.GetValueNames(Result); end; function TAppSettings.GetValueName(Index: TAppSettingIndex): String; begin Result := FSettings[Index].Name; end; function TAppSettings.GetKeyNames: TStringList; begin PrepareRegistry; Result := TStringList.Create; FRegistry.GetKeyNames(Result); end; function TAppSettings.DeleteValue(Index: TAppSettingIndex; FormatName: String=''): Boolean; var ValueName: String; begin PrepareRegistry; ValueName := GetValueName(Index); if FormatName <> '' then ValueName := Format(ValueName, [FormatName]); Result := FRegistry.DeleteValue(ValueName); end; function TAppSettings.DeleteValue(ValueName: String): Boolean; begin Result := FRegistry.DeleteValue(ValueName); end; procedure TAppSettings.DeleteCurrentKey; var KeyPath: String; begin PrepareRegistry; if IsEmpty(FSessionPath) then raise Exception.CreateFmt(_('No path set, won''t delete root key %s'), [FRegistry.CurrentPath]) else begin KeyPath := REGKEY_SESSIONS + '\' + FSessionPath; ResetPath; FRegistry.DeleteKey(KeyPath); end; end; procedure TAppSettings.MoveCurrentKey(TargetPath: String); var KeyPath: String; begin PrepareRegistry; if IsEmpty(FSessionPath) then raise Exception.CreateFmt(_('No path set, won''t move root key %s'), [FRegistry.CurrentPath]) else begin KeyPath := REGKEY_SESSIONS + '\' + FSessionPath; ResetPath; FRegistry.MoveKey(KeyPath, TargetPath, True); end; end; function TAppSettings.ValueExists(Index: TAppSettingIndex): Boolean; var ValueName: String; begin PrepareRegistry; ValueName := GetValueName(Index); Result := FRegistry.ValueExists(ValueName); end; function TAppSettings.SessionPathExists(SessionPath: String): Boolean; begin Result := FRegistry.KeyExists(FBasePath + REGKEY_SESSIONS + '\' + SessionPath); end; function TAppSettings.IsEmptyKey: Boolean; var TestList: TStringList; begin TestList := GetValueNames; Result := (not FRegistry.HasSubKeys) and (TestList.Count = 0); TestList.Free; end; function TAppSettings.GetDefaultInt(Index: TAppSettingIndex): Integer; begin // Return default integer value Result := FSettings[Index].DefaultInt; end; function TAppSettings.GetDefaultBool(Index: TAppSettingIndex): Boolean; begin // Return default boolean value Result := FSettings[Index].DefaultBool; end; function TAppSettings.GetDefaultString(Index: TAppSettingIndex): String; begin // Return default string value Result := FSettings[Index].DefaultString; end; procedure TAppSettings.Read(Index: TAppSettingIndex; FormatName: String; DataType: TAppSettingDataType; var I: Integer; var B: Boolean; var S: String; DI: Integer; DB: Boolean; DS: String); var ValueName: String; begin // Read user setting value from registry I := FSettings[Index].DefaultInt; B := FSettings[Index].DefaultBool; S := FSettings[Index].DefaultString; if DI<>0 then I := DI; if DB<>False then B := DB; if DS<>'' then S := DS; ValueName := FSettings[Index].Name; if FormatName <> '' then ValueName := Format(ValueName, [FormatName]); if FSettings[Index].Session and IsEmpty(FSessionPath) then raise Exception.Create(_('Attempt to read session setting without session path')); if (not FSettings[Index].Session) and IsNotEmpty(FSessionPath) then SessionPath := '' else PrepareRegistry; if FSettings[Index].Synced then begin case DataType of adInt: I := FSettings[Index].CurrentInt; adBool: B := FSettings[Index].CurrentBool; adString: S := FSettings[Index].CurrentString; else raise Exception.CreateFmt(_(SUnsupportedSettingsDatatype), [FSettings[Index].Name]); end; end else if FRegistry.ValueExists(ValueName) then begin Inc(FReads); case DataType of adInt: I := FRegistry.ReadInteger(ValueName); adBool: B := FRegistry.ReadBool(ValueName); adString: S := FRegistry.ReadString(ValueName); else raise Exception.CreateFmt(_(SUnsupportedSettingsDatatype), [FSettings[Index].Name]); end; end; if (FormatName = '') and (FSessionPath = '') then begin FSettings[Index].Synced := True; FSettings[Index].CurrentInt := I; FSettings[Index].CurrentBool := B; FSettings[Index].CurrentString := S; end; end; function TAppSettings.ReadInt(Index: TAppSettingIndex; FormatName: String=''; Default: Integer=0): Integer; var S: String; B: Boolean; begin Read(Index, FormatName, adInt, Result, B, S, Default, False, ''); end; function TAppSettings.ReadBool(Index: TAppSettingIndex; FormatName: String=''; Default: Boolean=False): Boolean; var I: Integer; S: String; begin Read(Index, FormatName, adBool, I, Result, S, 0, Default, ''); end; function TAppSettings.ReadString(Index: TAppSettingIndex; FormatName: String=''; Default: String=''): String; var I: Integer; B: Boolean; begin Read(Index, FormatName, adString, I, B, Result, 0, False, Default); end; function TAppSettings.ReadString(ValueName: String): String; begin PrepareRegistry; Result := FRegistry.ReadString(ValueName); end; procedure TAppSettings.Write(Index: TAppSettingIndex; FormatName: String; DataType: TAppSettingDataType; I: Integer; B: Boolean; S: String); var ValueName: String; SameAsCurrent: Boolean; begin // Write user setting value to registry ValueName := FSettings[Index].Name; if FormatName <> '' then ValueName := Format(ValueName, [FormatName]); if FSettings[Index].Session and IsEmpty(FSessionPath) then raise Exception.Create(_('Attempt to write session setting without session path')); if (not FSettings[Index].Session) and IsNotEmpty(FSessionPath) then SessionPath := '' else PrepareRegistry; case DataType of adInt: begin SameAsCurrent := FSettings[Index].Synced and (I = FSettings[Index].CurrentInt); if not SameAsCurrent then begin FRegistry.WriteInteger(ValueName, I); Inc(FWrites); end; FSettings[Index].CurrentInt := I; end; adBool: begin SameAsCurrent := FSettings[Index].Synced and (B = FSettings[Index].CurrentBool); if not SameAsCurrent then begin FRegistry.WriteBool(ValueName, B); Inc(FWrites); end; FSettings[Index].CurrentBool := B; end; adString: begin SameAsCurrent := FSettings[Index].Synced and (S = FSettings[Index].CurrentString); if not SameAsCurrent then begin FRegistry.WriteString(ValueName, S); Inc(FWrites); end; FSettings[Index].CurrentString := S; end; else raise Exception.CreateFmt(_(SUnsupportedSettingsDatatype), [FSettings[Index].Name]); end; if (FormatName = '') and (FSessionPath = '') then FSettings[Index].Synced := True; end; procedure TAppSettings.WriteInt(Index: TAppSettingIndex; Value: Integer; FormatName: String=''); begin Write(Index, FormatName, adInt, Value, False, ''); end; procedure TAppSettings.WriteBool(Index: TAppSettingIndex; Value: Boolean; FormatName: String=''); begin Write(Index, FormatName, adBool, 0, Value, ''); end; procedure TAppSettings.WriteString(Index: TAppSettingIndex; Value: String; FormatName: String=''); begin Write(Index, FormatName, adString, 0, False, Value); end; procedure TAppSettings.WriteString(ValueName, Value: String); begin PrepareRegistry; FRegistry.WriteString(ValueName, Value); end; function TAppSettings.GetSessionNames(ParentPath: String; var Folders: TStringList): TStringList; var i: Integer; CurPath: String; begin ResetPath; CurPath := FBasePath + REGKEY_SESSIONS + '\' + ParentPath; FRegistry.OpenKey(CurPath, False); Result := TStringList.Create; FRegistry.GetKeyNames(Result); for i:=Result.Count-1 downto 0 do begin FRegistry.OpenKey(CurPath+'\'+Result[i], False); if FRegistry.ValueExists(GetValueName(asSessionFolder)) then begin Folders.Add(Result[i]); Result.Delete(i); end; end; end; procedure TAppSettings.GetSessionPaths(ParentPath: String; var Sessions: TStringList); var Folders, Names: TStringList; i: Integer; begin Folders := TStringList.Create; Names := GetSessionNames(ParentPath, Folders); for i:=0 to Names.Count-1 do Sessions.Add(ParentPath+Names[i]); for i:=0 to Folders.Count-1 do GetSessionPaths(ParentPath+Folders[i]+'\', Sessions); Names.Free; Folders.Free; end; procedure TAppSettings.ImportSettings(Filename: String); var Content, Name, Value, KeyPath: String; Lines, Segments: TStringList; i: Integer; DataType: TRegDataType; begin // Load registry settings from file Content := ReadTextfile(FileName, nil); Lines := Explode(CRLF, Content); for i:=0 to Lines.Count-1 do begin // Each line has 3 segments: reg path | data type | value. Continue if explode finds less or more than 3. Segments := Explode(DELIMITER, Lines[i]); if Segments.Count <> 3 then continue; KeyPath := FBasePath + ExtractFilePath(Segments[0]); Name := ExtractFileName(Segments[0]); DataType := TRegDataType(StrToInt(Segments[1])); FRegistry.OpenKey(KeyPath, True); if FRegistry.ValueExists(Name) then Continue; // Don't touch value if already there Value := ''; if Segments.Count >= 3 then Value := Segments[2]; case DataType of rdString: begin Value := StringReplace(Value, CHR13REPLACEMENT, #13, [rfReplaceAll]); Value := StringReplace(Value, CHR10REPLACEMENT, #10, [rfReplaceAll]); FRegistry.WriteString(Name, Value); end; rdInteger: FRegistry.WriteInteger(Name, MakeInt(Value)); rdBinary, rdUnknown, rdExpandString: ErrorDialog(Name+' has an unsupported data type.'); end; Segments.Free; end; Lines.Free; end; procedure TAppSettings.ExportSettings(Filename: String); var Content, Value: String; DataType: TRegDataType; procedure ReadKeyToContent(Path: String); var Names: TStringList; i: Integer; SubPath: String; begin // Recursively read values in keys and their subkeys into "content" variable FRegistry.OpenKey(Path, True); SubPath := Copy(Path, Length(FBasePath)+1, MaxInt); Names := TStringList.Create; FRegistry.GetValueNames(Names); for i:=0 to Names.Count-1 do begin DataType := FRegistry.GetDataType(Names[i]); Content := Content + SubPath + Names[i] + DELIMITER + IntToStr(Integer(DataType)) + DELIMITER; case DataType of rdString: begin Value := FRegistry.ReadString(Names[i]); Value := StringReplace(Value, #13, CHR13REPLACEMENT, [rfReplaceAll]); Value := StringReplace(Value, #10, CHR10REPLACEMENT, [rfReplaceAll]); end; rdInteger: Value := IntToStr(FRegistry.ReadInteger(Names[i])); rdBinary, rdUnknown, rdExpandString: ErrorDialog(Names[i]+' has an unsupported data type.'); end; Content := Content + Value + CRLF; end; Names.Clear; FRegistry.GetKeyNames(Names); for i:=0 to Names.Count-1 do ReadKeyToContent(Path + Names[i] + '\'); Names.Free; end; begin // Save registry settings to file Content := ''; ReadKeyToContent(FBasePath); SaveUnicodeFile(FileName, Content); end; procedure TAppSettings.ExportSettings; begin ExportSettings(FSettingsFile); end; end.