mirror of
https://github.com/HeidiSQL/HeidiSQL.git
synced 2025-08-06 18:24:26 +08:00
4600 lines
170 KiB
ObjectPascal
4600 lines
170 KiB
ObjectPascal
unit apphelpers;
|
||
|
||
|
||
// -------------------------------------
|
||
// Functions-library
|
||
// -------------------------------------
|
||
|
||
|
||
interface
|
||
|
||
uses
|
||
System.Classes, System.SysUtils, Vcl.Graphics, Vcl.GraphUtil, Vcl.ClipBrd, Vcl.Dialogs, Vcl.Forms, Vcl.Controls, Winapi.ShellApi,
|
||
Winapi.Windows, Winapi.ShlObj, Winapi.ActiveX, VirtualTrees, VirtualTrees.Types, SynRegExpr, Winapi.Messages, System.Math,
|
||
System.Win.Registry, System.DateUtils, System.Generics.Collections, System.Contnrs, System.StrUtils, System.AnsiStrings, Winapi.TlHelp32, System.Types,
|
||
dbconnection, dbstructures, dbstructures.mysql, SynMemo, Vcl.Menus, Winapi.WinInet, gnugettext, Vcl.Themes,
|
||
System.Character, Vcl.ImgList, System.UITypes, Vcl.ActnList, Winapi.WinSock, System.IOUtils, Vcl.StdCtrls, Vcl.ComCtrls,
|
||
Winapi.CommCtrl, Winapi.KnownFolders, SynUnicode, SynEdit;
|
||
|
||
type
|
||
|
||
TSortItemOrder = (sioAscending, sioDescending);
|
||
TSortItem = class(TPersistent)
|
||
public
|
||
Column: String;
|
||
Order: TSortItemOrder;
|
||
procedure Assign(Source: TPersistent); override;
|
||
end;
|
||
TSortItems = class(TObjectList<TSortItem>)
|
||
public
|
||
function AddNew(Column: String=''; Order: TSortItemOrder=sioAscending): TSortItem;
|
||
function ComposeOrderClause(Connection: TDBConnection): String;
|
||
function FindByColumn(Column: String): TSortItem;
|
||
procedure Assign(Source: TSortItems);
|
||
end;
|
||
|
||
TLineBreaks = (lbsNone, lbsWindows, lbsUnix, lbsMac, lbsWide, lbsMixed);
|
||
|
||
TUTF8NoBOMEncoding = class(TUTF8Encoding)
|
||
public
|
||
function GetPreamble: TBytes; override;
|
||
end;
|
||
|
||
TDBObjectEditor = class(TFrame)
|
||
private
|
||
FModified: Boolean;
|
||
procedure SetModified(Value: Boolean);
|
||
protected
|
||
FMainSynMemo: TSynMemo; // Main editor in case of routine, view, trigger or event
|
||
FMainSynMemoPreviousTopLine: Integer;
|
||
function ObjectExists: Boolean;
|
||
public
|
||
DBObject: TDBObject;
|
||
constructor Create(AOwner: TComponent); override;
|
||
destructor Destroy; override;
|
||
procedure Init(Obj: TDBObject); virtual;
|
||
function DeInit: TModalResult; virtual;
|
||
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;
|
||
function GetSQLWithoutComments: String;
|
||
public
|
||
LeftOffset, RightOffset: Integer;
|
||
constructor Create(Owner: TSQLBatch);
|
||
property SQL: String read GetSQL;
|
||
property SQLWithoutComments: String read GetSQLWithoutComments;
|
||
property Size: Integer read GetSize;
|
||
end;
|
||
TSQLBatch = class(TObjectList<TSQLSentence>)
|
||
private
|
||
FSQL: String;
|
||
procedure SetSQL(Value: String);
|
||
function GetSize: Integer;
|
||
function GetSQLWithoutComments: String; overload;
|
||
public
|
||
class function GetSQLWithoutComments(FullSQL: String): String; overload;
|
||
property Size: Integer read GetSize;
|
||
property SQL: String read FSQL write SetSQL;
|
||
property SQLWithoutComments: String read GetSQLWithoutComments;
|
||
end;
|
||
|
||
// Download
|
||
THttpDownload = class(TObject)
|
||
private
|
||
FOwner: TComponent;
|
||
FURL: String;
|
||
FLastContent: 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;
|
||
property LastContent: String read FLastContent;
|
||
end;
|
||
|
||
// Extended string list with support for empty values
|
||
TExtStringList = class(TStringList)
|
||
private
|
||
function GetValue(const Name: string): string;
|
||
procedure SetValue(const Name, Value: string); reintroduce;
|
||
public
|
||
property Values[const Name: string]: string read GetValue write SetValue;
|
||
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;
|
||
FQueryStartedAt: TDateTime;
|
||
FQueryTime: Cardinal;
|
||
FQueryNetTime: Cardinal;
|
||
FRowsAffected: Int64;
|
||
FRowsFound: Int64;
|
||
FWarningCount: Int64;
|
||
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 QueryStartedAt: TDateTime read FQueryStartedAt;
|
||
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 LogFromThread(Msg: String; Category: TDBLogCategory);
|
||
end;
|
||
|
||
TSqlTranspiler = class(TObject)
|
||
class function CreateTable(SQL: String; SourceDb, TargetDb: TDBConnection): String;
|
||
end;
|
||
|
||
TAppSettingDataType = (adInt, adBool, adString);
|
||
TAppSettingIndex = (asHiddenColumns, asFilter, asSort, asDisplayedColumnsSorted, asLastSessions,
|
||
asLastActiveSession, asAutoReconnect, asRestoreLastUsedDB, asLastUsedDB, asTreeBackground, asIgnoreDatabasePattern, asLogFileDdl, asLogFileDml, asLogFilePath,
|
||
asFontName, asFontSize, asTabWidth, asDataFontName, asDataFontSize, asDataLocalNumberFormat, asLowercaseHex, asHintsOnResultTabs, asHightlightSameTextBackground,
|
||
asLogsqlnum, asLogsqlwidth, asSessionLogsDirectory, asLogHorizontalScrollbar, asSQLColActiveLine,
|
||
asSQLColMatchingBraceForeground, asSQLColMatchingBraceBackground,
|
||
asMaxColWidth, asDatagridMaximumRows, asDatagridRowsPerStep, asGridRowLineCount, asColumnHeaderClick, asReuseEditorConfiguration,
|
||
asLogToFile, asMainWinMaximized, asMainWinLeft, asMainWinTop, asMainWinWidth,
|
||
asMainWinHeight, asMainWinOnMonitor, asCoolBandIndex, asCoolBandBreak, asCoolBandWidth, asToolbarShowCaptions, asQuerymemoheight, asDbtreewidth,
|
||
asDataPreviewHeight, asDataPreviewEnabled, asLogHeight, asQueryhelperswidth, asStopOnErrorsInBatchMode,
|
||
asWrapLongLines, asCodeFolding, asDisplayBLOBsAsText, asSingleQueries, asMemoEditorWidth, asMemoEditorHeight, asMemoEditorMaximized,
|
||
asMemoEditorWrap, asMemoEditorHighlighter, asMemoEditorAlwaysFormatCode, asDelimiter, asSQLHelpWindowLeft, asSQLHelpWindowTop, asSQLHelpWindowWidth,
|
||
asSQLHelpWindowHeight, asSQLHelpPnlLeftWidth, asSQLHelpPnlRightTopHeight, asHost,
|
||
asUser, asPassword, asCleartextPluginEnabled, asWindowsAuth, asLoginPrompt, asPort, asLibrary, asAllProviders,
|
||
asSSHtunnelActive, asPlinkExecutable, asSshExecutable, asSSHtunnelHost, asSSHtunnelHostPort, asSSHtunnelPort, asSSHtunnelUser,
|
||
asSSHtunnelPassword, asSSHtunnelTimeout, asSSHtunnelPrivateKey, asSSLActive, asSSLKey,
|
||
asSSLCert, asSSLCA, asSSLCipher, asSSLWarnUnused, asNetType, asCompressed, asLocalTimeZone, asQueryTimeout, asKeepAlive,
|
||
asStartupScriptFilename, asDatabases, asComment, asDatabaseFilter, asTableFilter, asFilterVT, asExportSQLCreateDatabases,
|
||
asExportSQLCreateTables, asExportSQLDataHow, asExportSQLDataInsertSize, asExportSQLFilenames, asExportZIPFilenames, asExportSQLDirectories,
|
||
asExportSQLDatabase, asExportSQLServerDatabase, asExportSQLOutput, asExportSQLAddComments, asExportSQLRemoveAutoIncrement, asExportSQLRemoveDefiner,
|
||
asGridExportWindowWidth, asGridExportWindowHeight, asGridExportOutputCopy, asGridExportOutputFile,
|
||
asGridExportFilename, asGridExportRecentFiles, asGridExportEncoding, asGridExportFormat, asGridExportSelection,
|
||
asGridExportColumnNames, asGridExportIncludeAutoInc, asGridExportIncludeQuery, asGridExportRemoveLinebreaks,
|
||
asGridExportSeparator, asGridExportEncloser, asGridExportTerminator, asGridExportNull,
|
||
|
||
asGridExportClpColumnNames, asGridExportClpIncludeAutoInc, asGridExportClpRemoveLinebreaks,
|
||
asGridExportClpSeparator, asGridExportClpEncloser, asGridExportClpTerminator, asGridExportClpNull,
|
||
|
||
asCSVImportSeparator, asCSVImportEncloser, asCSVImportTerminator, asCSVImportFieldEscaper, asCSVImportWindowWidth, asCSVImportWindowHeight,
|
||
asCSVImportFilename, asCSVImportFieldsEnclosedOptionally, asCSVImportIgnoreLines, asCSVImportLowPriority, asCSVImportLocalNumbers,
|
||
asCSVImportDuplicateHandling, asCSVImportParseMethod,
|
||
asUpdatecheck, asUpdatecheckBuilds, asUpdatecheckInterval, asUpdatecheckLastrun, asUpdateCheckWindowWidth, asUpdateCheckWindowHeight,
|
||
asTableToolsWindowWidth, asTableToolsWindowHeight, asTableToolsTreeWidth,
|
||
asTableToolsFindTextTab, asTableToolsFindText, asTableToolsFindSQL, asTableToolsDatatype, asTableToolsFindCaseSensitive, asTableToolsFindMatchType, asFileImportWindowWidth, asFileImportWindowHeight,
|
||
asEditVarWindowWidth, asEditVarWindowHeight, asUsermanagerWindowWidth, asUsermanagerWindowHeight, asUsermanagerListWidth,
|
||
asSelectDBOWindowWidth, asSelectDBOWindowHeight,
|
||
asSessionManagerListWidth, asSessionManagerWindowWidth, asSessionManagerWindowHeight, asSessionManagerWindowLeft, asSessionManagerWindowTop,
|
||
asCopyTableWindowHeight, asCopyTableWindowWidth, asCopyTableColumns, asCopyTableKeys, asCopyTableForeignKeys,
|
||
asCopyTableData, asCopyTableRecentFilter, asServerVersion, asServerVersionFull, asLastConnect,
|
||
asConnectCount, asRefusedCount, asSessionCreated, asDoUsageStatistics,
|
||
asLastUsageStatisticCall, asWheelZoom, asDisplayBars, asMySQLBinaries, asCustomSnippetsDirectory,
|
||
asPromptSaveFileOnTabClose, asRestoreTabs, asTabCloseOnDoubleClick, asWarnUnsafeUpdates, asQueryWarningsMessage, asQueryGridLongSortRowNum,
|
||
asCompletionProposal, asCompletionProposalInterval, asCompletionProposalSearchOnMid, asCompletionProposalWidth, asCompletionProposalNbLinesInWindow, asAutoUppercase,
|
||
asTabsToSpaces, asFilterPanel, asAllowMultipleInstances, asFindDialogSearchHistory, asGUIFontName, asGUIFontSize,
|
||
asTheme, asIconPack, asWebSearchBaseUrl,
|
||
asFindDialogReplaceHistory, asMaxQueryResults, asLogErrors,
|
||
asLogUserSQL, asLogSQL, asLogInfos, asLogDebug, asLogScript, asLogTimestamp, 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,
|
||
asIncrementalSearch, asQueryHistoryEnabled, asQueryHistoryKeepDays,
|
||
asColumnSelectorWidth, asColumnSelectorHeight, asDonatedEmail, asFavoriteObjects, asFavoriteObjectsOnly, asFullTableStatus, asLineBreakStyle,
|
||
asPreferencesWindowWidth, asPreferencesWindowHeight,
|
||
asFileDialogEncoding,
|
||
asThemePreviewWidth, asThemePreviewHeight, asThemePreviewTop, asThemePreviewLeft,
|
||
asCreateDbCollation, asRealTrailingZeros,
|
||
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;
|
||
FStoredPath: String;
|
||
FRegistry: TRegistry;
|
||
FPortableMode: Boolean;
|
||
FPortableModeReadOnly: Boolean;
|
||
FRestoreTabsInitValue: Boolean;
|
||
FSettingsFile: String;
|
||
FSettings: Array[TAppSettingIndex] of TAppSetting;
|
||
const FPortableLockFileBase: String='portable.lock';
|
||
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 ReadIntDpiAware(Index: TAppSettingIndex; AControl: TControl; 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 WriteIntDpiAware(Index: TAppSettingIndex; AControl: TControl; 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;
|
||
procedure StorePath;
|
||
procedure RestorePath;
|
||
property SessionPath: String read FSessionPath write SetSessionPath;
|
||
property PortableMode: Boolean read FPortableMode;
|
||
property PortableModeReadOnly: Boolean read FPortableModeReadOnly write FPortableModeReadOnly;
|
||
property Writes: Integer read FWrites;
|
||
procedure ImportSettings(Filename: String);
|
||
function ExportSettings(Filename: String): Boolean; overload;
|
||
function ExportSettings: Boolean; overload;
|
||
// Common directories
|
||
function DirnameUserAppData: String;
|
||
function DirnameUserDocuments: String;
|
||
function DirnameSnippets: String;
|
||
function DirnameBackups: String;
|
||
function DirnameHighlighters: String;
|
||
// "Static" options, initialized in OnCreate only. For settings which need a restart to take effect.
|
||
property RestoreTabsInitValue: Boolean read FRestoreTabsInitValue;
|
||
end;
|
||
|
||
{$I const.inc}
|
||
|
||
function Implode(Separator: String; a: TStrings): String;
|
||
function Explode(Separator, Text: String) :TStringList;
|
||
procedure ExplodeQuotedList(Text: String; var List: TStringList);
|
||
function StrEllipsis(const S: String; MaxLen: Integer; FromLeft: Boolean=True): String;
|
||
function encrypt(str: String): String;
|
||
function decrypt(str: String): String;
|
||
function HTMLSpecialChars(str: String): String;
|
||
function EncodeURLParam(const Value: String): String;
|
||
procedure StreamWrite(S: TStream; Text: String = '');
|
||
function _GetFileSize(Filename: String): Int64;
|
||
function DeleteFileWithUndo(sFileName: String): Boolean;
|
||
function MakeInt(Str: String) : Int64;
|
||
function MakeFloat(Str: String): Extended;
|
||
function RoundCommercial(e: Extended): Int64;
|
||
function CleanupNumber(Str: String): String;
|
||
function IsInt(Str: String): Boolean;
|
||
function IsFloat(Str: String): Boolean;
|
||
function ScanLineBreaks(Text: String): TLineBreaks;
|
||
function fixNewlines(txt: String): String;
|
||
function GetLineBreak(LineBreakIndex: TLineBreaks): String;
|
||
procedure RemoveNullChars(var Text: String; var HasNulls: Boolean);
|
||
function GetShellFolder(FolderId: TGUID): String;
|
||
function ValidFilename(Str: 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=''; RunHidden: Boolean=False);
|
||
function getFirstWord(text: String; MustStartWithWordChar: Boolean=True): String;
|
||
function RegExprGetMatch(Expression: String; var Input: String; ReturnMatchNum: Integer; DeleteFromSource, CaseInsensitive: Boolean): String; Overload;
|
||
function RegExprGetMatch(Expression: String; Input: String; ReturnMatchNum: Integer): String; Overload;
|
||
function ExecRegExprI(const ARegExpr, AInputStr: RegExprString): Boolean;
|
||
function FormatByteNumber( Bytes: Int64; Decimals: Byte = 1 ): String; Overload;
|
||
function FormatByteNumber( Bytes: String; Decimals: Byte = 1 ): String; Overload;
|
||
function FormatTimeNumber(Seconds: Double; 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;
|
||
procedure DeInitializeVTNodes(Sender: TBaseVirtualTree);
|
||
function FindNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode): PVirtualNode;
|
||
function SelectNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode=nil): Boolean; overload;
|
||
function SelectNode(VT: TVirtualStringTree; Node: PVirtualNode; ClearSelection: Boolean=True): Boolean; overload;
|
||
procedure GetVTSelection(VT: TVirtualStringTree; var SelectedCaptions: TStringList; var FocusedCaption: String);
|
||
procedure SetVTSelection(VT: TVirtualStringTree; SelectedCaptions: TStringList; FocusedCaption: String);
|
||
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;
|
||
function DateTimeToStrDef(DateTime: TDateTime; Default: String): String;
|
||
function TruncDef(X: Real; Default: Int64): Int64;
|
||
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 StringListCompareByLength(List: TStringList; Index1, Index2: Integer): Integer;
|
||
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; FooterText: String=''): Integer; overload;
|
||
function ErrorDialog(Msg: string): Integer; overload;
|
||
function ErrorDialog(const Title, Msg: string): Integer; overload;
|
||
function GetLocaleString(const ResourceId: Integer): WideString;
|
||
function GetHTMLCharsetByEncoding(Encoding: TEncoding): String;
|
||
procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectionParameters; var FileNames: TStringList; var RunFrom: String);
|
||
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 FileIsWritable(FilePath: String): Boolean;
|
||
function GetProductInfo(dwOSMajorVersion, dwOSMinorVersion, dwSpMajorVersion, dwSpMinorVersion: DWORD; out pdwReturnedProductType: DWORD): BOOL stdcall; external kernel32 delayed;
|
||
function GetCurrentPackageFullName(out Len: Cardinal; Name: PWideChar): Integer; stdcall; external kernel32 delayed;
|
||
function GetUwpFullName: String;
|
||
function RunningAsUwp: Boolean;
|
||
function GetThemeColor(Color: TColor): TColor;
|
||
function ThemeIsDark(ThemeName: String): Boolean;
|
||
function ProcessExists(pid: Cardinal; ExeNamePattern: String): Boolean;
|
||
procedure ToggleCheckBoxWithoutClick(chk: TCheckBox; State: Boolean);
|
||
function SynCompletionProposalPrettyText(ImageIndex: Integer; LeftText, CenterText, RightText: String; LeftColor: TColor=-1; CenterColor: TColor=-1; RightColor: TColor=-1): String;
|
||
function PopupComponent(Sender: TObject): TComponent;
|
||
function IsWine: Boolean;
|
||
function DirSep: Char;
|
||
procedure FindComponentInstances(BaseForm: TComponent; ClassType: TClass; var List: TObjectList);
|
||
function WebColorStrToColorDef(WebColor: string; Default: TColor): TColor;
|
||
{function GetCurrentUserSID: String;}
|
||
|
||
var
|
||
AppSettings: TAppSettings;
|
||
MutexHandle: THandle = 0;
|
||
SystemImageList: TImageList = nil;
|
||
mtCriticalConfirmation: TMsgDlgType = mtCustom;
|
||
ConfirmIcon: TIcon;
|
||
NumberChars: TSysCharSet;
|
||
LibHandleUser32: THandle;
|
||
UTF8NoBOMEncoding: TUTF8NoBOMEncoding;
|
||
DateTimeNever: TDateTime;
|
||
IsWineStored: Integer = -1;
|
||
|
||
implementation
|
||
|
||
uses main, extra_controls;
|
||
|
||
|
||
|
||
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 Implode(Separator: 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 + Separator;
|
||
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 := 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 StrEllipsis(const S: String; MaxLen: Integer; FromLeft: Boolean=True): String;
|
||
begin
|
||
Result := S;
|
||
if Length(Result) <= MaxLen then
|
||
Exit;
|
||
if FromLeft then begin
|
||
SetLength(Result, MaxLen);
|
||
Result[MaxLen] := '<27>';
|
||
end else begin
|
||
Result := Copy(Result, Length(Result)-MaxLen, Length(Result));
|
||
Result := '<27>' + Result;
|
||
end;
|
||
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 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
|
||
Partly taken from https://www.delphipraxis.net/194137-getfilesize-welches-ist-die-bessere-funktion-2.html
|
||
@param string Filename
|
||
@return int64 Size in bytes
|
||
}
|
||
function _GetFileSize(Filename: String): Int64;
|
||
var
|
||
Attr: TWin32FileAttributeData;
|
||
begin
|
||
FillChar(Attr, SizeOf(Attr), 0);
|
||
if GetFileAttributesEx(PChar(Filename), GetFileExInfoStandard, @Attr) then
|
||
begin
|
||
Result := Int64(Attr.nFileSizeHigh) shl 32 + Int64(Attr.nFileSizeLow);
|
||
end
|
||
else
|
||
Result := -1;
|
||
end;
|
||
|
||
|
||
function DeleteFileWithUndo(sFileName: string): Boolean;
|
||
var
|
||
fos: TSHFileOpStruct;
|
||
begin
|
||
FillChar(fos, SizeOf(fos), 0);
|
||
fos.wFunc := FO_DELETE;
|
||
fos.pFrom := PChar(sFileName + #0);
|
||
fos.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
|
||
Result := (0 = ShFileOperation(fos));
|
||
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], NumberChars) 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;
|
||
if Str[i] = FormatSettings.ThousandSeparator then
|
||
Continue;
|
||
Result := Result + Str[i];
|
||
end else
|
||
Break;
|
||
end;
|
||
if (Result = '') or (Result = '-') then
|
||
Result := '0';
|
||
end;
|
||
|
||
|
||
function IsInt(Str: String): Boolean;
|
||
begin
|
||
Result := IntToStr(MakeInt(Str)) = Str;
|
||
end;
|
||
|
||
|
||
function IsFloat(Str: String): Boolean;
|
||
begin
|
||
Result := FloatToStr(MakeFloat(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 RoundCommercial(e: Extended): Int64;
|
||
begin
|
||
// "Kaufm<66>nnisch runden"
|
||
// In contrast to Delphi's Round() which rounds *.5 to the next even number
|
||
Result := Trunc(e);
|
||
if Frac(e) >= 0.5 then
|
||
Result := Result + 1;
|
||
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, SeekSize: 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;
|
||
SeekSize := Min(Length(Text), SIZE_MB);
|
||
if SeekSize = 0 then
|
||
Exit;
|
||
i := 1;
|
||
repeat
|
||
c := Text[i];
|
||
if c = #13 then begin
|
||
if (i < SeekSize) 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 > SeekSize;
|
||
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 GetLineBreak(LineBreakIndex: TLineBreaks): String;
|
||
begin
|
||
case LineBreakIndex of
|
||
lbsUnix: Result := LB_UNIX;
|
||
lbsMac: Result := LB_MAC;
|
||
else Result := CRLF;
|
||
end;
|
||
end;
|
||
|
||
|
||
{***
|
||
Mangle input text so that SynEdit can load it.
|
||
}
|
||
procedure RemoveNullChars(var Text: String; var HasNulls: Boolean);
|
||
var
|
||
i, Len: Integer;
|
||
begin
|
||
HasNulls := False;
|
||
Len := Length(Text);
|
||
for i:=1 to Len do begin
|
||
if Text[i] = #0 then begin
|
||
Text[i] := #32; // space
|
||
HasNulls := True;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
{***
|
||
Get the path of a Windows(r)-shellfolder, specified by a KNOWNFOLDERID constant
|
||
@see https://docs.microsoft.com/en-us/windows/win32/shell/knownfolderid
|
||
@param TGUID constant
|
||
@return string Path
|
||
}
|
||
function GetShellFolder(FolderId: TGUID): String;
|
||
var
|
||
Path: PWideChar;
|
||
begin
|
||
if Succeeded(SHGetKnownFolderPath(FolderId, 0, 0, Path)) then begin
|
||
Result := Path;
|
||
end else begin
|
||
Result := EmptyStr;
|
||
end;
|
||
end;
|
||
|
||
|
||
|
||
{***
|
||
Remove special characters from a filename
|
||
|
||
@param string Filename
|
||
@return string
|
||
}
|
||
function ValidFilename(Str: String): String;
|
||
var
|
||
c: Char;
|
||
begin
|
||
Result := Str;
|
||
for c in TPath.GetInvalidFileNameChars do begin
|
||
Result := StringReplace(Result, c, '_', [rfReplaceAll]);
|
||
end;
|
||
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=''; RunHidden: Boolean=False);
|
||
var
|
||
Msg: String;
|
||
ShowCmd: Integer;
|
||
begin
|
||
ShowCmd := IfThen(RunHidden, SW_HIDE, SW_SHOWNORMAL);
|
||
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), ShowCmd);
|
||
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;
|
||
|
||
|
||
function RegExprGetMatch(Expression: String; var Input: String; ReturnMatchNum: Integer; DeleteFromSource, CaseInsensitive: Boolean): String;
|
||
var
|
||
rx: TRegExpr;
|
||
begin
|
||
Result := '';
|
||
rx := TRegExpr.Create;
|
||
rx.ModifierI := CaseInsensitive;
|
||
rx.Expression := Expression;
|
||
if rx.Exec(Input) then begin
|
||
if rx.SubExprMatchCount >= ReturnMatchNum then begin
|
||
Result := rx.Match[ReturnMatchNum];
|
||
if DeleteFromSource then begin
|
||
Delete(Input, rx.MatchPos[ReturnMatchNum], rx.MatchLen[ReturnMatchNum]);
|
||
Input := Trim(Input);
|
||
end;
|
||
end;
|
||
end;
|
||
rx.Free;
|
||
end;
|
||
|
||
|
||
function RegExprGetMatch(Expression: String; Input: String; ReturnMatchNum: Integer): String;
|
||
begin
|
||
// Version without possibility to delete captured match from input
|
||
Result := RegExprGetMatch(Expression, Input, ReturnMatchNum, False, False);
|
||
end;
|
||
|
||
|
||
function ExecRegExprI(const ARegExpr, AInputStr: RegExprString): Boolean;
|
||
var
|
||
r: TRegExpr;
|
||
begin
|
||
Result := False;
|
||
r := TRegExpr.Create;
|
||
r.ModifierI := True;
|
||
try
|
||
r.Expression := ARegExpr;
|
||
Result := r.Exec(AInputStr);
|
||
finally
|
||
r.Free;
|
||
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: Double; DisplaySeconds: Boolean): String;
|
||
var
|
||
d, h, m, s, ts: Integer;
|
||
begin
|
||
s := TruncDef(Seconds, 0);
|
||
ts := TruncDef((Seconds - s) * 10, 0); // ts = tenth of a second
|
||
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 begin
|
||
Result := Format('%d '+_('days')+', %.2d:%.2d:%.2d', [d, h, m, s]);
|
||
Result := Result + '.' + IntToStr(ts);
|
||
end
|
||
else begin
|
||
Result := Format('%d '+_('days')+', %.2d:%.2d h', [d, h, m]);
|
||
end;
|
||
end else begin
|
||
if DisplaySeconds then begin
|
||
Result := Format('%.2d:%.2d:%.2d', [h, m, s]);
|
||
Result := Result + '.' + IntToStr(ts);
|
||
end
|
||
else begin
|
||
Result := Format('%.2d:%.2d h', [h, m]);
|
||
end;
|
||
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
|
||
Writer: TStreamWriter;
|
||
begin
|
||
Writer := TStreamWriter.Create(Filename, False, UTF8NoBOMEncoding);
|
||
Writer.Write(Text);
|
||
Writer.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 through SynEdit's GetEncoding. 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
|
||
SynEnc: TSynEncoding;
|
||
WithBOM: Boolean;
|
||
begin
|
||
SynEnc := SynUnicode.GetEncoding(Stream, WithBOM);
|
||
case SynEnc of
|
||
seUTF8: begin
|
||
if WithBOM then
|
||
Result := TEncoding.UTF8
|
||
else
|
||
Result := UTF8NoBOMEncoding;
|
||
end;
|
||
seUTF16LE: Result := TEncoding.Unicode;
|
||
seUTF16BE: Result := TEncoding.BigEndianUnicode;
|
||
seAnsi: Result := TEncoding.ANSI;
|
||
else Result := UTF8NoBOMEncoding;
|
||
end;
|
||
end;
|
||
|
||
|
||
function ReadTextfileChunk(Stream: TFileStream; Encoding: TEncoding; ChunkSize: Int64 = 0): String;
|
||
const
|
||
BufferPadding = 1;
|
||
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 True do begin
|
||
Inc(i);
|
||
try
|
||
SetLength(LBuffer, ChunkSize);
|
||
Stream.ReadBuffer(Pointer(LBuffer)^, ChunkSize);
|
||
LBuffer := Encoding.Convert(Encoding, TEncoding.Unicode, LBuffer);
|
||
// Success, exit loop
|
||
Break;
|
||
except
|
||
on E:EEncodingError do begin
|
||
if i=10 then // Give up
|
||
Raise;
|
||
Stream.Position := StartPosition;
|
||
Inc(ChunkSize, BufferPadding);
|
||
end;
|
||
end;
|
||
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:<3A><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>' + CRLF +
|
||
'StartFragment:000089' + CRLF +
|
||
'EndFragment:<3A><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>' + CRLF +
|
||
HTMLContent + CRLF;
|
||
HTMLContent := System.AnsiStrings.StringReplace(
|
||
HTMLContent, '<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>',
|
||
System.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
|
||
// This is called either in some early stage, or from preferences dialog
|
||
VT.BeginUpdate;
|
||
SingleLineHeight := GetTextHeight(VT.Font) + 7;
|
||
// Multiline nodes?
|
||
VT.DefaultNodeHeight := SingleLineHeight * MultiLineCount;
|
||
VT.Header.Height := SingleLineHeight;
|
||
// 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;
|
||
|
||
if toVariableNodeHeight in VT.TreeOptions.MiscOptions then
|
||
VT.HintMode := hmHint // Show cell contents with linebreakds in datagrid and querygrid's
|
||
else
|
||
VT.HintMode := hmTooltip; // Just a quick tooltip for clipped nodes
|
||
// Apply case insensitive incremental search event
|
||
if VT.IncrementalSearch <> VirtualTrees.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;
|
||
|
||
|
||
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;
|
||
Node := nil;
|
||
try
|
||
if Assigned(ParentNode) then
|
||
Node := VT.GetFirstChild(ParentNode)
|
||
else
|
||
Node := VT.GetFirst;
|
||
except
|
||
// Sporadically, TBaseVirtualTree.GetFirst throws an exception when reading FRoot.FirstChild
|
||
// Tab restoring is sometimes crashing for that reason.
|
||
end;
|
||
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;
|
||
|
||
|
||
function SelectNode(VT: TVirtualStringTree; idx: Int64; ParentNode: PVirtualNode=nil): Boolean; overload;
|
||
var
|
||
Node: PVirtualNode;
|
||
begin
|
||
// Helper to focus and highlight a node by its index
|
||
Node := FindNode(VT, idx, ParentNode);
|
||
if Assigned(Node) then
|
||
Result := SelectNode(VT, Node)
|
||
else
|
||
Result := False;
|
||
end;
|
||
|
||
|
||
function SelectNode(VT: TVirtualStringTree; Node: PVirtualNode; ClearSelection: Boolean=True): Boolean; overload;
|
||
var
|
||
OldFocus: PVirtualNode;
|
||
begin
|
||
if Node = VT.RootNode then
|
||
Node := nil;
|
||
OldFocus := VT.FocusedNode;
|
||
Result := True;
|
||
if (Node <> OldFocus) and Assigned(VT.OnFocusChanging) then begin
|
||
VT.OnFocusChanging(VT, OldFocus, Node, VT.FocusedColumn, VT.FocusedColumn, Result);
|
||
end;
|
||
if Result then begin
|
||
if ClearSelection then
|
||
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;
|
||
end;
|
||
|
||
|
||
procedure GetVTSelection(VT: TVirtualStringTree; var SelectedCaptions: TStringList; var FocusedCaption: String);
|
||
var
|
||
Node: PVirtualNode;
|
||
InvalidationTag: Integer;
|
||
begin
|
||
// Return captions of selected nodes
|
||
InvalidationTag := vt.Tag;
|
||
vt.Tag := VTREE_LOADED;
|
||
SelectedCaptions.Clear;
|
||
Node := GetNextNode(VT, nil, true);
|
||
while Assigned(Node) do begin
|
||
SelectedCaptions.Add(VT.Text[Node, VT.Header.MainColumn]);
|
||
if Node = VT.FocusedNode then begin
|
||
FocusedCaption := VT.Text[Node, VT.Header.MainColumn];
|
||
end;
|
||
Node := GetNextNode(VT, Node, true);
|
||
end;
|
||
vt.Tag := InvalidationTag;
|
||
end;
|
||
|
||
|
||
procedure SetVTSelection(VT: TVirtualStringTree; SelectedCaptions: TStringList; FocusedCaption: String);
|
||
var
|
||
Node: PVirtualNode;
|
||
idx: Integer;
|
||
DoFocusChange: Boolean;
|
||
begin
|
||
// Restore selected nodes based on captions list
|
||
DoFocusChange := False;
|
||
Node := GetNextNode(VT, nil, false);
|
||
while Assigned(Node) do begin
|
||
idx := SelectedCaptions.IndexOf(VT.Text[Node, VT.Header.MainColumn]);
|
||
if idx > -1 then
|
||
VT.Selected[Node] := True;
|
||
if (not FocusedCaption.IsEmpty) and (VT.Text[Node, VT.Header.MainColumn] = FocusedCaption) then begin
|
||
VT.FocusedNode := Node;
|
||
DoFocusChange := True;
|
||
end;
|
||
Node := GetNextNode(VT, Node, false);
|
||
end;
|
||
// Fire focus change event if there was a focused one before
|
||
if DoFocusChange and Assigned(VT.OnFocusChanged) then begin
|
||
VT.OnFocusChanged(VT, VT.FocusedNode, VT.FocusedColumn);
|
||
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;
|
||
|
||
|
||
function DateTimeToStrDef(DateTime: TDateTime; Default: String) : String;
|
||
begin
|
||
try
|
||
if DateTime = 0 then
|
||
Result := Default
|
||
else
|
||
Result := DateTimeToStr(DateTime);
|
||
except
|
||
on EInvalidOp do Result := Default;
|
||
end;
|
||
end;
|
||
|
||
|
||
function TruncDef(X: Real; Default: Int64): Int64;
|
||
begin
|
||
try
|
||
Result := Trunc(X);
|
||
except
|
||
on EInvalidOp do Result := Default;
|
||
end;
|
||
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;
|
||
|
||
|
||
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
|
||
Conn: TDBConnection;
|
||
SQLFunc: TSQLFunction;
|
||
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
|
||
Conn := MainForm.ActiveConnection;
|
||
// Known SQL keywords, get converted to UPPERCASE
|
||
AllKeywords := TStringList.Create;
|
||
AllKeywords.Text := MySQLKeywords.Text;
|
||
|
||
for SQLFunc in Conn.SQLFunctions do begin
|
||
// Leave out operator functions like ">>", and the "X()" function so hex values don't get touched
|
||
if (SQLFunc.Declaration <> '') and (SQLFunc.Name <> 'X') then
|
||
AllKeywords.Add(SQLFunc.Name);
|
||
end;
|
||
Datatypes := Conn.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;
|
||
|
||
|
||
{ *** TSortItem }
|
||
|
||
procedure TSortItem.Assign(Source: TPersistent);
|
||
var
|
||
SourceItem: TSortItem;
|
||
begin
|
||
if Source is TSortItem then begin
|
||
SourceItem := Source as TSortItem;
|
||
Column := SourceItem.Column;
|
||
Order := SourceItem.Order;
|
||
end
|
||
else
|
||
Inherited;
|
||
end;
|
||
|
||
|
||
{ *** TSortItems }
|
||
|
||
function TSortItems.AddNew(Column: String=''; Order: TSortItemOrder=sioAscending): TSortItem;
|
||
begin
|
||
Result := TSortItem.Create;
|
||
Result.Column := Column;
|
||
Result.Order := Order;
|
||
Add(Result);
|
||
end;
|
||
|
||
|
||
function TSortItems.ComposeOrderClause(Connection: TDBConnection): String;
|
||
var
|
||
SortItem: TSortItem;
|
||
SortOrder: String;
|
||
begin
|
||
// Concat all sort options to an ORDER BY clause
|
||
Result := '';
|
||
for SortItem in Self do begin
|
||
if Result <> '' then
|
||
Result := Result + ', ';
|
||
if SortItem.Order = sioAscending then
|
||
SortOrder := Connection.GetSQLSpecifity(spOrderAsc)
|
||
else
|
||
SortOrder := Connection.GetSQLSpecifity(spOrderDesc);
|
||
Result := Result + Connection.QuoteIdent(SortItem.Column) + ' ' + SortOrder;
|
||
end;
|
||
end;
|
||
|
||
|
||
function TSortItems.FindByColumn(Column: String): TSortItem;
|
||
var
|
||
SortItem: TSortItem;
|
||
begin
|
||
Result := nil;
|
||
for SortItem in Self do begin
|
||
if SortItem.Column = Column then begin
|
||
Result := SortItem;
|
||
Break;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
procedure TSortItems.Assign(Source: TSortItems);
|
||
var
|
||
Item, ItemCopy: TSortItem;
|
||
begin
|
||
Clear;
|
||
for Item in Source do begin
|
||
ItemCopy := AddNew;
|
||
ItemCopy.Assign(Item);
|
||
end;
|
||
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;
|
||
FMainSynMemo := nil;
|
||
DBObject := nil;
|
||
TranslateComponent(Self);
|
||
end;
|
||
|
||
destructor TDBObjectEditor.Destroy;
|
||
begin
|
||
inherited;
|
||
end;
|
||
|
||
procedure TDBObjectEditor.SetModified(Value: Boolean);
|
||
begin
|
||
FModified := Value;
|
||
end;
|
||
|
||
function TDBObjectEditor.ObjectExists: Boolean;
|
||
begin
|
||
Result := not DBObject.Name.IsEmpty;
|
||
end;
|
||
|
||
procedure TDBObjectEditor.Init(Obj: TDBObject);
|
||
var
|
||
editName: TWinControl;
|
||
SynMemo: TSynMemo;
|
||
popup: TPopupMenu;
|
||
Item: TMenuItem;
|
||
i: Integer;
|
||
IsRefresh: Boolean;
|
||
begin
|
||
Mainform.ShowStatusMsg(_('Initializing editor ...'));
|
||
Mainform.LogSQL(Self.ClassName+'.Init, using object "'+Obj.Name+'"', lcDebug);
|
||
TExtForm.FixControls(Self);
|
||
IsRefresh := Assigned(DBObject) and DBObject.IsSameAs(Obj);
|
||
if IsRefresh and Assigned(FMainSynMemo) then
|
||
FMainSynMemoPreviousTopLine := FMainSynMemo.TopLine
|
||
else
|
||
FMainSynMemoPreviousTopLine := 0;
|
||
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.VirtualImageListMain;
|
||
|
||
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);
|
||
|
||
Item := TMenuItem.Create(popup);
|
||
Item.Action := MainForm.actReformatSQL;
|
||
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));
|
||
// Todo: no save button for objects without minimum requirements, such as name. See #1134
|
||
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;
|
||
|
||
|
||
|
||
|
||
// 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 := 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 IsIconic(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
|
||
try
|
||
Result := Result.Parent;
|
||
except
|
||
on E:EAccessViolation do
|
||
Break;
|
||
end;
|
||
// 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 StringListCompareByLength(List: TStringList; Index1, Index2: Integer): Integer;
|
||
begin
|
||
// Sort TStringList items by their length
|
||
Result := CompareValue(List[Index2].Length, List[Index1].Length);
|
||
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; FooterText: String=''): Integer;
|
||
var
|
||
m: String;
|
||
Dialog: TTaskDialog;
|
||
Btn: TTaskDialogButtonItem;
|
||
MsgButton: TMsgDlgBtn;
|
||
rx: TRegExpr;
|
||
KeepAskingValue: Boolean;
|
||
Hotkeys: String;
|
||
WebSearchUrl, WebSearchHost: String;
|
||
|
||
procedure AddButton(BtnCaption: String; BtnResult: TModalResult; ResourceId: Integer=0);
|
||
var
|
||
i: Integer;
|
||
cap: String;
|
||
begin
|
||
Btn := TTaskDialogButtonItem(Dialog.Buttons.Add);
|
||
cap := '';
|
||
if ResourceId > 0 then begin
|
||
// Prefer string from user32.dll
|
||
// May be empty on Wine!
|
||
cap := GetLocaleString(ResourceId)
|
||
end;
|
||
if cap.IsEmpty then begin
|
||
cap := _(BtnCaption);
|
||
for i:=1 to Length(cap) do begin
|
||
// Auto apply hotkey
|
||
if (Pos(LowerCase(cap[i]), Hotkeys) = 0) and TCharacter.IsLetter(cap[i]) then begin
|
||
Hotkeys := Hotkeys + LowerCase(cap[i]);
|
||
Insert('&', cap, i);
|
||
break;
|
||
end;
|
||
end;
|
||
end;
|
||
Btn.Caption := cap;
|
||
Btn.ModalResult := BtnResult;
|
||
if (DlgType = mtCriticalConfirmation) and (BtnResult = mrCancel) then
|
||
Btn.Default := True;
|
||
end;
|
||
begin
|
||
// Remember current path and restore it later, so the caller does not try to read from the wrong path after this dialog
|
||
AppSettings.StorePath;
|
||
|
||
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 := [];
|
||
if Assigned(MainForm) then
|
||
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 Assigned(MainForm) and (MainForm.ActiveConnection <> nil) then
|
||
Dialog.Caption := MainForm.ActiveConnection.Parameters.SessionName + ': ' + Dialog.Caption;
|
||
rx := TRegExpr.Create;
|
||
rx.Expression := 'https?://\S+';
|
||
Dialog.Text := rx.Replace(Msg, '<a href="$0">$0</a>', True);
|
||
rx.Free;
|
||
|
||
// Main icon, and footer link
|
||
case DlgType of
|
||
mtWarning:
|
||
Dialog.MainIcon := tdiWarning;
|
||
mtError: begin
|
||
Dialog.MainIcon := tdiError;
|
||
WebSearchUrl := AppSettings.ReadString(asWebSearchBaseUrl);
|
||
WebSearchUrl := StringReplace(WebSearchUrl, '%q', EncodeURLParam(Copy(Msg, 1, 1000)), []);
|
||
rx := TRegExpr.Create;
|
||
rx.Expression := 'https?://(www\.)?([^/]+)/';
|
||
if rx.Exec(WebSearchUrl) then
|
||
WebSearchHost := rx.Match[2]
|
||
else
|
||
WebSearchHost := '[unknown host]';
|
||
rx.Free;
|
||
Dialog.FooterText := IfThen(FooterText.IsEmpty, '', FooterText + sLineBreak + sLineBreak) +
|
||
'<a href="'+WebSearchUrl+'">'+_('Find some help on this error')+' (=> '+WebSearchHost+')</a>';
|
||
Dialog.FooterIcon := tdiInformation;
|
||
end;
|
||
mtInformation:
|
||
Dialog.MainIcon := tdiInformation;
|
||
mtConfirmation, mtCustom: begin
|
||
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, 805);
|
||
mbNo: AddButton('No', mrNo, 806);
|
||
mbOK: AddButton('OK', mrOk, 800);
|
||
mbCancel: AddButton('Cancel', mrCancel, 801);
|
||
mbAbort: AddButton('Abort', mrAbort, 802);
|
||
mbRetry: AddButton('Retry', mrRetry, 803);
|
||
mbIgnore: AddButton('Ignore', mrIgnore, 804);
|
||
mbAll: AddButton('All', mrAll);
|
||
mbNoToAll: AddButton('No to all', mrNoToAll);
|
||
mbYesToAll: AddButton('Yes to all', mrYesToAll);
|
||
mbClose: AddButton('Close', mrClose, 807);
|
||
end;
|
||
end;
|
||
|
||
// Checkbox, s'il vous plait?
|
||
KeepAskingValue := True;
|
||
if KeepAskingSetting <> asUnused then begin
|
||
if (not (mbNo in Buttons)) and (Buttons <> [mbOK]) then
|
||
raise Exception.CreateFmt(_('Missing "No" button in %() call'), ['MessageDialog']);
|
||
KeepAskingValue := AppSettings.ReadBool(KeepAskingSetting);
|
||
Dialog.Flags := Dialog.Flags + [tfVerificationFlagChecked];
|
||
if Buttons = [mbOK] then
|
||
Dialog.VerificationText := _('Keep showing this dialog.')
|
||
else
|
||
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 not Title.IsEmpty then
|
||
m := Title + SLineBreak + SLineBreak + m;
|
||
if not FooterText.IsEmpty then
|
||
m := m + SLineBreak + SLineBreak + FooterText;
|
||
|
||
if KeepAskingSetting <> asUnused then
|
||
KeepAskingValue := AppSettings.ReadBool(KeepAskingSetting)
|
||
else
|
||
KeepAskingValue := True;
|
||
|
||
if KeepAskingValue then
|
||
Result := MessageDlg(m, DlgType, Buttons, 0)
|
||
else
|
||
Result := mrNo;
|
||
end;
|
||
|
||
AppSettings.RestorePath;
|
||
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 GetLocaleString(const ResourceId: Integer): WideString;
|
||
var
|
||
Buffer: WideString;
|
||
BufferLen: Integer;
|
||
begin
|
||
Result := '';
|
||
if LibHandleUser32 <> 0 then begin
|
||
SetLength(Buffer, 255);
|
||
BufferLen := LoadStringW(LibHandleUser32, ResourceId, PWideChar(Buffer), Length(Buffer));
|
||
if BufferLen <> 0 then
|
||
Result := Copy(Buffer, 1, BufferLen);
|
||
end;
|
||
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 RunFrom: String);
|
||
var
|
||
rx: TRegExpr;
|
||
ExeName, SessName, Host, Lib, Port, User, Pass, Socket, AllDatabases,
|
||
SSLPrivateKey, SSLCACertificate, SSLCertificate, SSLCipher: String;
|
||
NetType, WindowsAuth, WantSSL, CleartextPluginEnabled: 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;
|
||
|
||
// --runfrom=scheduler after build update
|
||
RunFrom := GetParamValue('rf', 'runfrom');
|
||
|
||
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);
|
||
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');
|
||
Lib := GetParamValue('l', 'library');
|
||
User := GetParamValue('u', 'user');
|
||
Pass := GetParamValue('p', 'password');
|
||
CleartextPluginEnabled := StrToIntDef(GetParamValue('cte', 'cleartextenabled'), -1);
|
||
Socket := GetParamValue('S', 'socket');
|
||
Port := GetParamValue('P', 'port');
|
||
AllDatabases := GetParamValue('db', 'databases');
|
||
WindowsAuth := StrToIntDef(GetParamValue('W', 'winauth'), -1);
|
||
WantSSL := StrToIntDef(GetParamValue('ssl', 'ssl'), -1);
|
||
SSLPrivateKey := GetParamValue('sslpk', 'sslprivatekey');
|
||
SSLCACertificate := GetParamValue('sslca', 'sslcacertificate');
|
||
SSLCertificate := GetParamValue('sslcert', 'sslcertificate');
|
||
SSLCipher := GetParamValue('sslcip', 'sslcipher');
|
||
// Leave out support for startup script, seems reasonable for command line connecting
|
||
|
||
if (Host <> '') or (User <> '') or (Pass <> '') or (Port <> '') or (Socket <> '') or (AllDatabases <> '') 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 Lib <> '' then ConnectionParams.LibraryOrProvider := Lib;
|
||
if ConnectionParams.LibraryOrProvider.IsEmpty then ConnectionParams.LibraryOrProvider := ConnectionParams.DefaultLibrary;
|
||
if User <> '' then ConnectionParams.Username := User;
|
||
if Pass <> '' then ConnectionParams.Password := Pass;
|
||
if CleartextPluginEnabled in [0,1] then
|
||
ConnectionParams.CleartextPluginEnabled := Boolean(CleartextPluginEnabled);
|
||
if Port <> '' then ConnectionParams.Port := StrToIntDef(Port, 0);
|
||
if Socket <> '' then begin
|
||
ConnectionParams.Hostname := Socket;
|
||
ConnectionParams.NetType := ntMySQL_NamedPipe;
|
||
end;
|
||
if AllDatabases <> '' then ConnectionParams.AllDatabasesStr := AllDatabases;
|
||
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: TExtStringList;
|
||
Year, Month, Day, Hour, Min, Sec, MSec: Word;
|
||
i: Integer;
|
||
begin
|
||
// Rich format output filename, replace certain markers. See issue #2622
|
||
Arguments := TExtStringList.Create;
|
||
|
||
if Assigned(DBObj) then begin
|
||
Arguments.Values['session'] := ValidFilename(DBObj.Connection.Parameters.SessionName);
|
||
Arguments.Values['host'] := ValidFilename(DBObj.Connection.Parameters.Hostname);
|
||
Arguments.Values['u'] := ValidFilename(DBObj.Connection.Parameters.Username);
|
||
Arguments.Values['db'] := ValidFilename(DBObj.Database);
|
||
end;
|
||
Arguments.Values['date'] := ValidFilename(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 not Anchor.IsEmpty then
|
||
Anchor := '#'+Anchor;
|
||
ShellExec(APPDOMAIN+'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 FileIsWritable(FilePath: String): Boolean;
|
||
var
|
||
hFile: DWORD;
|
||
begin
|
||
// Check if file is writable
|
||
if not FileExists(FilePath) then begin
|
||
// Return true if file does not exist
|
||
Result := True;
|
||
end else begin
|
||
hFile := CreateFile(PChar(FilePath), GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);
|
||
Result := hFile <> INVALID_HANDLE_VALUE;
|
||
CloseHandle(hFile);
|
||
end;
|
||
end;
|
||
|
||
|
||
function GetUwpFullName: String;
|
||
var
|
||
Len: Cardinal;
|
||
Name: String;
|
||
begin
|
||
// Detect current Microsoft Store package name
|
||
// See https://stackoverflow.com/questions/48549899/how-to-detect-universal-windows-platform-uwp-in-delphi
|
||
Result := '';
|
||
if (Win32MajorVersion > 6) or ((Win32MajorVersion = 6) and (Win32MinorVersion > 1)) then begin
|
||
// Windows 10, but not necessarily a Store App
|
||
Len := 0;
|
||
GetCurrentPackageFullName(Len, nil);
|
||
SetLength(Name, Len-1);
|
||
GetCurrentPackageFullName(Len, PWideChar(Name));
|
||
if not Name.IsEmpty then
|
||
Result := Trim(Name);
|
||
end;
|
||
end;
|
||
|
||
|
||
function RunningAsUwp: Boolean;
|
||
begin
|
||
Result := GetUwpFullName <> '';
|
||
end;
|
||
|
||
|
||
function GetThemeColor(Color: TColor): TColor;
|
||
begin
|
||
// Not required with vcl-style-utils:
|
||
// Result := TStyleManager.ActiveStyle.GetSystemColor(Color);
|
||
Result := Color;
|
||
end;
|
||
|
||
|
||
function ThemeIsDark(ThemeName: String): Boolean;
|
||
const
|
||
DarkThemes: String = 'Amakrits,Aqua Graphite,Auric,Carbon,Charcoal Dark Slate,Cobalt XEMedia,Glossy,Glow,Golden Graphite,Material,Onyx Blue,Ruby Graphite,TabletDark,Windows10 Dark,Windows10 SlateGray';
|
||
var
|
||
DarkThemesList: TStringList;
|
||
begin
|
||
DarkThemesList := Explode(',', DarkThemes);
|
||
Result := DarkThemesList.IndexOf(ThemeName) > -1;
|
||
DarkThemesList.Free;
|
||
end;
|
||
|
||
|
||
function ProcessExists(pid: Cardinal; ExeNamePattern: String): Boolean;
|
||
var
|
||
Proc: TProcessEntry32;
|
||
SnapShot: THandle;
|
||
ContinueLoop: Boolean;
|
||
begin
|
||
// Check if a given process id exists
|
||
SnapShot := CreateToolhelp32Snapshot(TH32CS_SnapProcess, 0);
|
||
Proc.dwSize := Sizeof(Proc);
|
||
Result := False;
|
||
ContinueLoop := Process32First(SnapShot, Proc);
|
||
while ContinueLoop do begin
|
||
Result := (Proc.th32ProcessID = pid) and ContainsText(Proc.szExeFile, ExeNamePattern);
|
||
if Result then
|
||
Break;
|
||
ContinueLoop := Process32Next(SnapShot, Proc);
|
||
end;
|
||
CloseHandle(Snapshot);
|
||
end;
|
||
|
||
|
||
procedure ToggleCheckBoxWithoutClick(chk: TCheckBox; State: Boolean);
|
||
var
|
||
ClickEvent: TNotifyEvent;
|
||
begin
|
||
ClickEvent := chk.OnClick;
|
||
chk.OnClick := nil;
|
||
chk.Checked := State;
|
||
chk.OnClick := ClickEvent;
|
||
end;
|
||
|
||
|
||
function SynCompletionProposalPrettyText(ImageIndex: Integer; LeftText, CenterText, RightText: String;
|
||
LeftColor: TColor=-1; CenterColor: TColor=-1; RightColor: TColor=-1): String;
|
||
const
|
||
LineFormat = '\image{%d}\hspace{5}\color{%s}%s\column{}\color{%s}%s\hspace{5}\color{%s}%s';
|
||
begin
|
||
// Return formatted item string for a TSynCompletionProposal
|
||
if LeftColor = -1 then LeftColor := clGrayText;
|
||
if CenterColor = -1 then CenterColor := clWindowText;
|
||
if RightColor = -1 then RightColor := clGrayText;
|
||
Result := Format(LineFormat, [ImageIndex, ColorToString(LeftColor), LeftText, ColorToString(CenterColor), CenterText, ColorToString(RightColor), RightText]);
|
||
end;
|
||
|
||
|
||
function PopupComponent(Sender: TObject): TComponent;
|
||
var
|
||
Menu: TObject;
|
||
begin
|
||
// Return owner component of clicked menu item, probably combined with a TAction
|
||
Result := nil;
|
||
Menu := nil;
|
||
if Sender is TAction then
|
||
Sender := (Sender as TAction).ActionComponent;
|
||
|
||
if Sender is TMenuItem then
|
||
Menu := (Sender as TMenuItem).GetParentMenu
|
||
else if Sender is TPopupMenu then
|
||
Menu := Sender;
|
||
|
||
if Menu is TPopupMenu then
|
||
Result := (Menu as TPopupMenu).PopupComponent;
|
||
end;
|
||
|
||
|
||
function IsWine: Boolean;
|
||
var
|
||
NTHandle: THandle;
|
||
wine_nt_to_unix_file_name: procedure(p1:pointer; p2:pointer); stdcall;
|
||
begin
|
||
// Detect if we're running on Wine, not on native Windows
|
||
// Idea taken from http://ruminatedrumblings.blogspot.com/2008/04/detecting-virtualized-environment.html
|
||
if IsWineStored = -1 then begin
|
||
NTHandle := LoadLibrary('NTDLL.DLL');
|
||
if NTHandle>32 then
|
||
wine_nt_to_unix_file_name := GetProcAddress(NTHandle, 'wine_nt_to_unix_file_name')
|
||
else
|
||
wine_nt_to_unix_file_name := nil;
|
||
IsWineStored := IfThen(Assigned(wine_nt_to_unix_file_name), 1, 0);
|
||
FreeLibrary(NTHandle);
|
||
end;
|
||
Result := IsWineStored = 1;
|
||
end;
|
||
|
||
|
||
function DirSep: Char;
|
||
begin
|
||
if IsWine then
|
||
Result := '/'
|
||
else
|
||
Result := '\';
|
||
end;
|
||
|
||
procedure FindComponentInstances(BaseForm: TComponent; ClassType: TClass; var List: TObjectList);
|
||
var
|
||
i: Integer;
|
||
begin
|
||
for i:=0 to BaseForm.ComponentCount-1 do begin
|
||
if BaseForm.Components[i] is ClassType then
|
||
List.Add(BaseForm.Components[i] as ClassType)
|
||
else
|
||
FindComponentInstances(BaseForm.Components[i], ClassType, List);
|
||
end;
|
||
end;
|
||
|
||
function WebColorStrToColorDef(WebColor: string; Default: TColor): TColor;
|
||
begin
|
||
try
|
||
Result := WebColorStrToColor(WebColor);
|
||
except
|
||
Result := Default;
|
||
end;
|
||
end;
|
||
|
||
|
||
{ Get SID of current Windows user, probably useful in the future
|
||
function GetCurrentUserSID: string;
|
||
type
|
||
PTOKEN_USER = ^TOKEN_USER;
|
||
_TOKEN_USER = record
|
||
User: TSidAndAttributes;
|
||
end;
|
||
TOKEN_USER = _TOKEN_USER;
|
||
var
|
||
hToken: THandle;
|
||
cbBuf: Cardinal;
|
||
ptiUser: PTOKEN_USER;
|
||
bSuccess: Boolean;
|
||
StrSid: PWideChar;
|
||
begin
|
||
// Taken from https://stackoverflow.com/a/71730865/4110077
|
||
// SidToString does not exist, prefer WinApi.Windows.ConvertSidToStringSid()
|
||
Result := '';
|
||
|
||
// Get the calling thread's access token.
|
||
if not OpenThreadToken(GetCurrentThread(), TOKEN_QUERY, True, hToken) then
|
||
begin
|
||
if (GetLastError <> ERROR_NO_TOKEN) then
|
||
Exit;
|
||
|
||
// Retry against process token if no thread token exists.
|
||
if not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hToken) then
|
||
Exit;
|
||
end;
|
||
try
|
||
// Obtain the size of the user information in the token.
|
||
bSuccess := GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf);
|
||
ptiUser := nil;
|
||
try
|
||
while (not bSuccess) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) do
|
||
begin
|
||
ReallocMem(ptiUser, cbBuf);
|
||
bSuccess := GetTokenInformation(hToken, TokenUser, ptiUser, cbBuf, cbBuf);
|
||
end;
|
||
ConvertSidToStringSid(ptiUser.User.Sid, StrSid);
|
||
Result := StrSid;
|
||
finally
|
||
FreeMem(ptiUser);
|
||
end;
|
||
finally
|
||
CloseHandle(hToken);
|
||
end;
|
||
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;
|
||
FQueryStartedAt := Now;
|
||
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, LogMaxResultsDone: Boolean;
|
||
begin
|
||
inherited;
|
||
|
||
MaxAllowedPacket := 0;
|
||
i := 0;
|
||
ResultCount := 0;
|
||
ErrorAborted := False;
|
||
LogMaxResultsDone := 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 not SQL.IsEmpty then begin
|
||
if PacketSize >= MaxAllowedPacket then begin
|
||
// TODO: Log('Limiting batch packet size to '+FormatByteNumber(Length(SQL))+' with '+FormatNumber(i-FUserQueryOffset)+' queries.', lcDebug);
|
||
Break;
|
||
end
|
||
else begin
|
||
// Don't append to the very last query. See issue #1583
|
||
SQL := SQL + '; ';
|
||
end;
|
||
end;
|
||
SQL := SQL + FBatch[i].SQL;
|
||
Inc(i);
|
||
end;
|
||
FQueriesInPacket := i - FBatchPosition;
|
||
end;
|
||
Synchronize(procedure begin MainForm.BeforeQueryExecution(Self); end);
|
||
try
|
||
FConnection.LockedByThread := Self;
|
||
DoStoreResult := ResultCount < AppSettings.ReadInt(asMaxQueryResults);
|
||
if (not DoStoreResult) and (not LogMaxResultsDone) then begin
|
||
// Inform user about preference setting for limiting result tabs
|
||
FConnection.Log(lcInfo,
|
||
f_('Reached maximum number of result tabs (%d). To display more results, increase setting in Preferences > SQL', [AppSettings.ReadInt(asMaxQueryResults)])
|
||
);
|
||
LogMaxResultsDone := True;
|
||
end;
|
||
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:EDbError do begin
|
||
if FStopOnErrors or (i = FBatch.Count - 1) then begin
|
||
FErrorMessage := E.Message;
|
||
ErrorAborted := True;
|
||
end;
|
||
end;
|
||
end;
|
||
FConnection.LockedByThread := nil;
|
||
Synchronize(procedure begin MainForm.AfterQueryExecution(Self); end);
|
||
// 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(procedure begin MainForm.FinishedQueryExecution(Self); end);
|
||
end;
|
||
|
||
|
||
procedure TQueryThread.LogFromThread(Msg: String; Category: TDBLogCategory);
|
||
begin
|
||
Queue(procedure begin FConnection.Log(Category, Msg); end);
|
||
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);
|
||
// Probably faster than Copy():
|
||
SetString(Result, PChar(FOwner.SQL) +LeftOffset -1, RightOffset-LeftOffset);
|
||
end;
|
||
|
||
|
||
function TSQLSentence.GetSQLWithoutComments: String;
|
||
begin
|
||
Result := FOwner.GetSQLWithoutComments(GetSQL);
|
||
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;
|
||
|
||
function TSQLBatch.GetSQLWithoutComments: String;
|
||
begin
|
||
Result := GetSQLWithoutComments(SQL);
|
||
end;
|
||
|
||
class function TSQLBatch.GetSQLWithoutComments(FullSQL: String): String;
|
||
var
|
||
InLineComment, InMultiLineComment: Boolean;
|
||
AddCur: Boolean;
|
||
i: Integer;
|
||
Cur, Prev1, Prev2: Char;
|
||
begin
|
||
// Strip comments out of SQL sentence
|
||
// TODO: leave quoted string literals and identifiers untouched
|
||
Result := '';
|
||
InLineComment := False;
|
||
InMultiLineComment := False;
|
||
Prev1 := #0;
|
||
Prev2 := #0;
|
||
for i:=1 to Length(FullSQL) do begin
|
||
Cur := FullSQL[i];
|
||
AddCur := True;
|
||
if i > 1 then Prev1 := FullSQL[i-1];
|
||
if i > 2 then Prev2 := FullSQL[i-2];
|
||
|
||
if (Cur = '*') and (Prev1 = '/') then begin
|
||
InMultiLineComment := True;
|
||
System.Delete(Result, Length(Result), 1); // Delete comment chars
|
||
end
|
||
else if InMultiLineComment and (Cur = '/') and (Prev1 = '*') then begin
|
||
InMultiLineComment := False;
|
||
System.Delete(Result, Length(Result), 1);
|
||
AddCur := False;
|
||
end;
|
||
|
||
if not InMultiLineComment then begin
|
||
if InLineComment and ((Cur = #13) or (Cur = #10)) then begin
|
||
InLineComment := False; // Reset
|
||
end
|
||
else if Cur = '#' then begin
|
||
InLineComment := True;
|
||
end
|
||
else if (Cur = ' ') and (Prev1 = '-') and (Prev2 = '-') then begin
|
||
InLineComment := True;
|
||
System.Delete(Result, Length(Result)-1, 2); // Delete comment chars
|
||
end;
|
||
end;
|
||
|
||
if AddCur and (not InLineComment) and (not InMultiLineComment) then begin
|
||
Result := Result + Cur;
|
||
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 AnsiChar;
|
||
Head: array[1..1024] of Char;
|
||
BytesInChunk, HeadSize, Reserved, TimeOutSeconds: Cardinal;
|
||
LocalFile: File;
|
||
DoStore: Boolean;
|
||
UserAgent, OS: String;
|
||
HttpStatus: Integer;
|
||
ContentChunk: UTF8String;
|
||
begin
|
||
DoStore := False;
|
||
if 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;
|
||
FLastContent := '';
|
||
try
|
||
UrlHandle := InternetOpenURL(NetHandle, PChar(FURL), nil, 0, INTERNET_FLAG_RELOAD, 0);
|
||
if (not Assigned(UrlHandle)) and FURL.StartsWith('https:', true) then begin
|
||
// Try again without SSL. See issue #65 and #1209
|
||
MainForm.LogSQL(f_('Could not open %s (%s) - trying again without SSL...', [FURL, SysErrorMessage(GetLastError)]), lcError);
|
||
FURL := ReplaceRegExpr('^https:', FURL, 'http:');
|
||
UrlHandle := InternetOpenURL(NetHandle, PChar(FURL), nil, 0, INTERNET_FLAG_RELOAD, 0);
|
||
end;
|
||
if not Assigned(UrlHandle) then begin
|
||
raise Exception.CreateFmt(_('Could not open %s (%s)'), [FURL, SysErrorMessage(GetLastError)]);
|
||
end;
|
||
|
||
// 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);
|
||
// Either store as file or in memory variable
|
||
if DoStore then begin
|
||
BlockWrite(LocalFile, Buffer, BytesInChunk)
|
||
end else begin
|
||
SetString(ContentChunk, PAnsiChar(@Buffer[1]), BytesInChunk);
|
||
FLastContent := FLastContent + String(ContentChunk);
|
||
end;
|
||
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;
|
||
|
||
|
||
|
||
{ TExtStringList }
|
||
// taken from https://stackoverflow.com/questions/33893377/can-i-prevent-tstringlist-removing-key-value-pair-when-value-set-to-empty
|
||
|
||
function TExtStringList.GetValue(const Name: string): string;
|
||
begin
|
||
Result := Self.GetValue(Name);
|
||
end;
|
||
|
||
|
||
procedure TExtStringList.SetValue(const Name, Value: string);
|
||
var
|
||
I: Integer;
|
||
begin
|
||
I := IndexOfName(Name);
|
||
if I < 0 then I := Add('');
|
||
Put(I, Name + NameValueSeparator + Value);
|
||
end;
|
||
|
||
|
||
{ TSqlTranspiler }
|
||
|
||
class function TSqlTranspiler.CreateTable(SQL: String; SourceDb, TargetDb: TDBConnection): String;
|
||
begin
|
||
Result := SQL;
|
||
|
||
if SourceDb.Parameters.IsMySQL(False) and TargetDb.Parameters.IsMariaDB then begin
|
||
// Remove COLLATE clause from virtual column definition:
|
||
// `tax_status` varchar(255) COLLATE utf8mb4_unicode_ci GENERATED ALWAYS AS (json_unquote(json_extract(`price`,'$.taxStatus'))) VIRTUAL
|
||
Result := ReplaceRegExpr('\sCOLLATE\s\w+(\s+GENERATED\s)', Result, '$1', [rroModifierI, rroUseSubstitution]);
|
||
end;
|
||
|
||
end;
|
||
|
||
|
||
|
||
{ TAppSettings }
|
||
|
||
constructor TAppSettings.Create;
|
||
var
|
||
rx: TRegExpr;
|
||
i: Integer;
|
||
DefaultSnippetsDirectory: String;
|
||
PortableLockFile: String;
|
||
NewFileHandle: THandle;
|
||
begin
|
||
inherited;
|
||
FRegistry := TRegistry.Create;
|
||
FReads := 0;
|
||
FWrites := 0;
|
||
|
||
PortableLockFile := ExtractFilePath(ParamStr(0)) + FPortableLockFileBase;
|
||
|
||
// 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;
|
||
// Default settings file, if not given per command line
|
||
if FSettingsFile = '' then
|
||
FSettingsFile := ExtractFilePath(ParamStr(0)) + 'portable_settings.txt';
|
||
// Backwards compatibility: only settings file exists, create lock file in that case
|
||
if FileExists(FSettingsFile) and (not FileExists(PortableLockFile)) then begin
|
||
NewFileHandle := FileCreate(PortableLockFile);
|
||
FileClose(NewFileHandle);
|
||
end;
|
||
|
||
// Switch to portable mode if lock file exists. File content is ignored.
|
||
FPortableMode := FileExists(PortableLockFile);
|
||
FPortableModeReadOnly := False;
|
||
|
||
if FPortableMode then begin
|
||
// Create file if only the lock file exists
|
||
if not FileExists(FSettingsFile) then begin
|
||
NewFileHandle := FileCreate(FSettingsFile);
|
||
FileClose(NewFileHandle);
|
||
end;
|
||
FBasePath := '\Software\' + APPNAME + ' Portable '+IntToStr(GetCurrentProcessId)+'\';
|
||
try
|
||
ImportSettings(FSettingsFile);
|
||
except
|
||
on E:Exception do
|
||
MessageDlg(E.Message, mtError, [mbOK], 0, mbOK);
|
||
end;
|
||
end else begin
|
||
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);
|
||
InitSetting(asIgnoreDatabasePattern, 'IgnoreDatabasePattern', 0, False, '', True);
|
||
InitSetting(asLogFileDdl, 'LogFileDdl', 0, False, '', True);
|
||
InitSetting(asLogFileDml, 'LogFileDml', 0, False, '', True);
|
||
InitSetting(asLogFilePath, 'LogFilePath', 0, False, DirnameUserAppData + 'Logs\%session\%db\%y%m%d.sql', 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(asLowercaseHex, 'LowercaseHex', 0, True);
|
||
InitSetting(asHintsOnResultTabs, 'HintsOnResultTabs', 0, True);
|
||
InitSetting(asHightlightSameTextBackground, 'HightlightSameTextBackground', GetThemeColor(clInfoBk));
|
||
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(asColumnHeaderClick, 'ColumnHeaderClick', 0, True);
|
||
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(asToolbarShowCaptions, 'ToolbarShowCaptions', 0, False);
|
||
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(asCodeFolding, 'CodeFolding', 0, True);
|
||
InitSetting(asDisplayBLOBsAsText, 'DisplayBLOBsAsText', 0, True);
|
||
InitSetting(asSingleQueries, 'SingleQueries', 0, True);
|
||
InitSetting(asMemoEditorWidth, 'MemoEditorWidth', 500);
|
||
InitSetting(asMemoEditorHeight, 'MemoEditorHeight', 200);
|
||
InitSetting(asMemoEditorMaximized, 'MemoEditorMaximized', 0, False);
|
||
InitSetting(asMemoEditorWrap, 'MemoEditorWrap', 0, False);
|
||
InitSetting(asMemoEditorHighlighter, 'MemoEditorHighlighter_%s', 0, False, 'General', True);
|
||
InitSetting(asMemoEditorAlwaysFormatCode, 'MemoEditorAlwaysFormatCode', 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(asHost, 'Host', 0, False, '', True);
|
||
InitSetting(asUser, 'User', 0, False, '', True);
|
||
InitSetting(asPassword, 'Password', 0, False, '', True);
|
||
InitSetting(asCleartextPluginEnabled, 'CleartextPluginEnabled', 0, False, '', True);
|
||
InitSetting(asWindowsAuth, 'WindowsAuth', 0, False, '', True);
|
||
InitSetting(asLoginPrompt, 'LoginPrompt', 0, False, '', True);
|
||
InitSetting(asPort, 'Port', 0, False, '', True);
|
||
InitSetting(asLibrary, 'Library', 0, False, '', True); // Gets its default in TConnectionParameters.Create
|
||
InitSetting(asAllProviders, 'AllProviders', 0, False);
|
||
InitSetting(asSSHtunnelActive, 'SSHtunnelActive', -1, False, '', True);
|
||
InitSetting(asPlinkExecutable, 'PlinkExecutable', 0, False, 'plink.exe'); // Legacy support with global setting
|
||
InitSetting(asSshExecutable, 'SshExecutable', 0, False, '', True);
|
||
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(asSSLWarnUnused, 'SSL_WarnUnused', 0, 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(asFilterVT, 'FilterVTHistory', 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(asExportSQLRemoveDefiner, 'ExportSQLRemoveDefiner', 0, True);
|
||
InitSetting(asGridExportWindowWidth, 'GridExportWindowWidth', 400);
|
||
InitSetting(asGridExportWindowHeight, 'GridExportWindowHeight', 480);
|
||
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(asGridExportRemoveLinebreaks, 'GridExportRemoveLinebreaks', 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(asGridExportClpColumnNames, 'GridExportClpColumnNames', 0, True);
|
||
InitSetting(asGridExportClpIncludeAutoInc, 'GridExportClpAutoInc', 0, True);
|
||
InitSetting(asGridExportClpRemoveLinebreaks, 'GridExportClpRemoveLinebreaks', 0, False);
|
||
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, DateToStr(DateTimeNever));
|
||
InitSetting(asUpdateCheckWindowWidth, 'UpdateCheckWindowWidth', 400);
|
||
InitSetting(asUpdateCheckWindowHeight, 'UpdateCheckWindowHeight', 460);
|
||
InitSetting(asTableToolsWindowWidth, 'TableTools_WindowWidth', 800);
|
||
InitSetting(asTableToolsWindowHeight, 'TableTools_WindowHeight', 420);
|
||
InitSetting(asTableToolsTreeWidth, 'TableTools_TreeWidth', 300);
|
||
InitSetting(asTableToolsFindTextTab, 'TableToolsFindTextTab', 0);
|
||
InitSetting(asTableToolsFindText, 'TableTools_FindText', 0, False, '');
|
||
InitSetting(asTableToolsFindSQL, 'TableToolsFindSQL', 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', 490);
|
||
InitSetting(asSessionManagerWindowLeft, 'SessionManager_WindowLeft', 50);
|
||
InitSetting(asSessionManagerWindowTop, 'SessionManager_WindowTop', 50);
|
||
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, DateToStr(DateTimeNever), 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, DateToStr(DateTimeNever));
|
||
InitSetting(asWheelZoom, 'WheelZoom', 0, True);
|
||
InitSetting(asDisplayBars, 'DisplayBars', 0, true);
|
||
InitSetting(asMySQLBinaries, 'MySQL_Binaries', 0, False, '');
|
||
// Default folder for snippets
|
||
if FPortableMode then
|
||
DefaultSnippetsDirectory := ExtractFilePath(ParamStr(0))
|
||
else
|
||
DefaultSnippetsDirectory := DirnameUserDocuments;
|
||
DefaultSnippetsDirectory := DefaultSnippetsDirectory + 'Snippets\';
|
||
InitSetting(asCustomSnippetsDirectory, 'CustomSnippetsDirectory', 0, False, DefaultSnippetsDirectory);
|
||
InitSetting(asPromptSaveFileOnTabClose, 'PromptSaveFileOnTabClose', 0, True);
|
||
// Restore tabs feature crashes often on old XP systems, see https://www.heidisql.com/forum.php?t=34044
|
||
InitSetting(asRestoreTabs, 'RestoreTabs', 0, Win32MajorVersion >= 6);
|
||
InitSetting(asTabCloseOnDoubleClick, 'TabCloseOnDoubleClick', 0, True);
|
||
InitSetting(asWarnUnsafeUpdates, 'WarnUnsafeUpdates', 0, True);
|
||
InitSetting(asQueryWarningsMessage, 'QueryWarningsMessage', 0, True);
|
||
InitSetting(asQueryGridLongSortRowNum, 'QueryGridLongSortRowNum', 10000);
|
||
InitSetting(asCompletionProposal, 'CompletionProposal', 0, True);
|
||
InitSetting(asCompletionProposalInterval, 'CompletionProposalInterval', 500);
|
||
InitSetting(asCompletionProposalSearchOnMid, 'CompletionProposalSearchOnMid', 0, True);
|
||
InitSetting(asCompletionProposalWidth, 'CompletionProposalWidth', 350);
|
||
InitSetting(asCompletionProposalNbLinesInWindow,'CompletionProposalNbLinesInWindow', 12);
|
||
InitSetting(asAutoUppercase, 'AutoUppercase', 0, True);
|
||
InitSetting(asTabsToSpaces, 'TabsToSpaces', 0, False);
|
||
InitSetting(asFilterPanel, 'FilterPanel', 0, True);
|
||
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(asTheme, 'Theme', 0, False, 'Windows');
|
||
InitSetting(asIconPack, 'IconPack', 0, False, 'Icons8');
|
||
InitSetting(asWebSearchBaseUrl, 'WebSearchBaseUrl', 0, False, 'https://www.ecosia.org/search?q=%query');
|
||
InitSetting(asMaxQueryResults, 'MaxQueryResults', 10);
|
||
InitSetting(asLogErrors, 'LogErrors', 0, True);
|
||
InitSetting(asLogUserSQL, 'LogUserSQL', 0, True);
|
||
InitSetting(asLogSQL, 'LogSQL', 0, True);
|
||
InitSetting(asLogScript, 'LogScript', 0, False);
|
||
InitSetting(asLogInfos, 'LogInfos', 0, True);
|
||
InitSetting(asLogDebug, 'LogDebug', 0, False);
|
||
InitSetting(asLogTimestamp, 'LogTimestamp', 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(asIncrementalSearch, 'IncrementalSearch', 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(lbsWindows));
|
||
InitSetting(asPreferencesWindowWidth, 'PreferencesWindowWidth', 740);
|
||
InitSetting(asPreferencesWindowHeight, 'PreferencesWindowHeight', 500);
|
||
InitSetting(asFileDialogEncoding, 'FileDialogEncoding_%s', 0);
|
||
InitSetting(asThemePreviewWidth, 'ThemePreviewWidth', 300);
|
||
InitSetting(asThemePreviewHeight, 'ThemePreviewHeight', 200);
|
||
InitSetting(asThemePreviewTop, 'ThemePreviewTop', 300);
|
||
InitSetting(asThemePreviewLeft, 'ThemePreviewLeft', 300);
|
||
InitSetting(asCreateDbCollation, 'CreateDbCollation', 0, False, '');
|
||
InitSetting(asRealTrailingZeros, 'RealTrailingZeros', 1);
|
||
|
||
// Initialization values
|
||
FRestoreTabsInitValue := ReadBool(asRestoreTabs);
|
||
|
||
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
|
||
try
|
||
ExportSettings;
|
||
except
|
||
// do nothing, even ShowMessage or ErrorDialog would trigger timer events followed by crashes;
|
||
end;
|
||
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.StorePath;
|
||
begin
|
||
FStoredPath := SessionPath;
|
||
end;
|
||
|
||
procedure TAppSettings.RestorePath;
|
||
begin
|
||
SessionPath := FStoredPath;
|
||
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 try
|
||
FRegistry.OpenKey(Folder, True);
|
||
except
|
||
on E:Exception do begin
|
||
// Recreate exception with a more useful message
|
||
E.Message := E.Message + CRLF + CRLF + 'While trying to open registry key "'+Folder+'"';
|
||
raise;
|
||
end;
|
||
end;
|
||
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);
|
||
FSettings[Index].Synced := False;
|
||
end;
|
||
|
||
|
||
function TAppSettings.DeleteValue(ValueName: String): Boolean;
|
||
begin
|
||
Result := FRegistry.DeleteValue(ValueName);
|
||
end;
|
||
|
||
|
||
procedure TAppSettings.DeleteCurrentKey;
|
||
var
|
||
KeyPath: String;
|
||
begin
|
||
// Delete the current registry key
|
||
// Note that, contrary to the documentation, .DeleteKey is done even when this key has subkeys
|
||
PrepareRegistry;
|
||
if FSessionPath.IsEmpty 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 FSessionPath.IsEmpty 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 FSessionPath.IsEmpty then
|
||
raise Exception.Create(_('Attempt to read session setting without session path'));
|
||
if (not FSettings[Index].Session) and (not FSessionPath.IsEmpty) 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.ReadIntDpiAware(Index: TAppSettingIndex; AControl: TControl; FormatName: String=''; Default: Integer=0): Integer;
|
||
begin
|
||
Result := ReadInt(Index, FormatName, Default);
|
||
Result := Round(Result * AControl.ScaleFactor);
|
||
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 FSessionPath.IsEmpty then
|
||
raise Exception.Create(_('Attempt to write session setting without session path'));
|
||
if (not FSettings[Index].Session) and (not FSessionPath.IsEmpty) 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.WriteIntDpiAware(Index: TAppSettingIndex; AControl: TControl; Value: Integer; FormatName: String='');
|
||
begin
|
||
Value := Round(Value / AControl.ScaleFactor);
|
||
WriteInt(Index, Value, FormatName);
|
||
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
|
||
// Issue #1111 describes a recursive endless loop, which may be caused by an empty key name here?
|
||
if Result[i].IsEmpty then
|
||
Continue;
|
||
// ... may also be caused by some non accessible key. Check result of .OpenKey before looking for "Folder" value:
|
||
if FRegistry.OpenKey(CurPath+'\'+Result[i], False) then begin
|
||
if FRegistry.ValueExists(GetValueName(asSessionFolder)) then begin
|
||
Folders.Add(Result[i]);
|
||
Result.Delete(i);
|
||
end;
|
||
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);
|
||
Sessions.Sort;
|
||
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
|
||
|
||
if not FileExists(Filename) then begin
|
||
raise Exception.CreateFmt('File does not exist: %s', [Filename]);
|
||
end;
|
||
|
||
Content := ReadTextfile(FileName, UTF8NoBOMEncoding);
|
||
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;
|
||
|
||
|
||
function TAppSettings.ExportSettings(Filename: String): Boolean;
|
||
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);
|
||
Result := True;
|
||
end;
|
||
|
||
|
||
function TAppSettings.ExportSettings: Boolean;
|
||
begin
|
||
Result := False;
|
||
if not FPortableModeReadOnly then begin
|
||
try
|
||
ExportSettings(FSettingsFile);
|
||
Result := True;
|
||
except
|
||
on E:Exception do begin
|
||
FPortableModeReadOnly := True;
|
||
Raise Exception.Create(E.Message + CRLF + CRLF
|
||
+ f_('Switching to read-only mode. Settings won''t be saved. Use the command line parameter %s to use a custom file path.', ['--psettings'])
|
||
);
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
function TAppSettings.DirnameUserAppData: String;
|
||
begin
|
||
// User folder for HeidiSQL's data (<user name>\Application Data)
|
||
Result := GetShellFolder(FOLDERID_RoamingAppData) + '\' + APPNAME + '\';
|
||
if not DirectoryExists(Result) then begin
|
||
ForceDirectories(Result);
|
||
end;
|
||
end;
|
||
|
||
|
||
function TAppSettings.DirnameUserDocuments: String;
|
||
begin
|
||
// "HeidiSQL" folder under user's documents folder, e.g. c:\Users\Mike\Documents\HeidiSQL\
|
||
Result := GetShellFolder(FOLDERID_Documents) + '\' + APPNAME + '\';
|
||
// Do not auto-create it, as we only use it for snippets which can also have a custom path.
|
||
end;
|
||
|
||
|
||
function TAppSettings.DirnameSnippets: String;
|
||
begin
|
||
// Folder for snippets
|
||
Result := ReadString(asCustomSnippetsDirectory);
|
||
if Result.IsEmpty then
|
||
Result := GetDefaultString(asCustomSnippetsDirectory);
|
||
Result := IncludeTrailingBackslash(Result);
|
||
if not DirectoryExists(Result) then begin
|
||
ForceDirectories(Result);
|
||
end;
|
||
end;
|
||
|
||
|
||
function TAppSettings.DirnameBackups: String;
|
||
begin
|
||
// Create backup folder if it does not exist and return it
|
||
if PortableMode then begin
|
||
Result := ExtractFilePath(Application.ExeName) + 'Backups\'
|
||
end else begin
|
||
Result := DirnameUserAppData + 'Backups\';
|
||
end;
|
||
if not DirectoryExists(Result) then begin
|
||
ForceDirectories(Result);
|
||
end;
|
||
end;
|
||
|
||
|
||
function TAppSettings.DirnameHighlighters: string;
|
||
begin
|
||
if PortableMode then begin
|
||
Result := ExtractFilePath(Application.ExeName) + 'Highlighters\'
|
||
end else begin
|
||
Result := DirnameUserAppData + 'Highlighters\';
|
||
end;
|
||
if not DirectoryExists(Result) then begin
|
||
ForceDirectories(Result);
|
||
end;
|
||
end;
|
||
|
||
|
||
|
||
{ TUTF8NoBOMEncoding }
|
||
|
||
function TUTF8NoBOMEncoding.GetPreamble: TBytes;
|
||
begin
|
||
SetLength(Result, 0);
|
||
end;
|
||
|
||
|
||
initialization
|
||
|
||
NumberChars := ['0'..'9', FormatSettings.DecimalSeparator, FormatSettings.ThousandSeparator];
|
||
|
||
LibHandleUser32 := LoadLibrary('User32.dll');
|
||
|
||
UTF8NoBOMEncoding := TUTF8NoBOMEncoding.Create;
|
||
|
||
DateTimeNever := MinDateTime;
|
||
|
||
ConfirmIcon := TIcon.Create;
|
||
ConfirmIcon.LoadFromResourceName(hInstance, 'Z_ICONQUESTION');
|
||
|
||
end.
|
||
|
||
|