mirror of
https://github.com/HeidiSQL/HeidiSQL.git
synced 2026-03-13 09:24:25 +08:00
4515 lines
160 KiB
ObjectPascal
4515 lines
160 KiB
ObjectPascal
unit apphelpers;
|
||
|
||
{$mode delphi}{$H+}
|
||
|
||
interface
|
||
|
||
uses
|
||
Classes, SysUtils, Generics.Collections, Controls, RegExpr, Math, FileUtil,
|
||
StrUtils, Graphics, GraphUtil, LCLIntf, Forms, Clipbrd, Process, ActnList, Menus, Dialogs,
|
||
Character, DateUtils, laz.VirtualTrees, SynEdit, SynCompletion, fphttpclient,
|
||
{$IFDEF WINDOWS} Windows, {$ENDIF} DelphiCompat,
|
||
dbconnection, dbstructures, jsonregistry, lazaruscompat, fpjson, SynEditKeyCmds, LazFileUtils, gettext, LazUTF8,
|
||
IniFiles, GraphType, Sockets;
|
||
|
||
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;
|
||
|
||
{ THttpDownload }
|
||
|
||
THttpDownload = class(TFPHttpClient)
|
||
private
|
||
FURL: String;
|
||
FTimeOut: Cardinal;
|
||
procedure SetTimeOut(Value: Cardinal);
|
||
public
|
||
constructor Create(Owner: TComponent); override;
|
||
procedure SendRequest(Filename: String); overload;
|
||
property URL: String read FURL write FURL;
|
||
property TimeOut: Cardinal read FTimeOut write SetTimeOut;
|
||
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;
|
||
FLogMsg: String;
|
||
FLogCategory: TDBLogCategory;
|
||
procedure BeforeQuery;
|
||
procedure AfterQuery;
|
||
procedure BatchFinished;
|
||
procedure Log;
|
||
public
|
||
property Connection: TDBConnection read FConnection;
|
||
property Batch: TSQLBatch read FBatch;
|
||
property TabNumber: Integer read FTabNumber;
|
||
property BatchPosition: Integer read FBatchPosition;
|
||
property QueriesInPacket: Integer read FQueriesInPacket;
|
||
property 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;
|
||
|
||
TClipboardHelper = class helper for TClipboard
|
||
private
|
||
function GetTryAsText: String;
|
||
procedure SetTryAsText(AValue: String);
|
||
public
|
||
property TryAsText: String read GetTryAsText write SetTryAsText;
|
||
end;
|
||
|
||
TWinControlHelper = class helper for TWinControl
|
||
public
|
||
procedure TrySetFocus;
|
||
end;
|
||
|
||
//TSimpleKeyValuePairs = TDictionary<String, String>;
|
||
|
||
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,
|
||
asShowRowId,
|
||
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, asSSLVerification, 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, asGridExportOpenFile,
|
||
asGridExportSeparator, asGridExportEncloser, asGridExportTerminator, asGridExportNull,
|
||
|
||
asGridExportClpColumnNames, asGridExportClpIncludeAutoInc, asGridExportClpRemoveLinebreaks,
|
||
asGridExportClpSeparator, asGridExportClpEncloser, asGridExportClpTerminator, asGridExportClpNull,
|
||
|
||
asCSVImportSeparator, asCSVImportEncloser, asCSVImportTerminator, asCSVImportFieldEscaper, asCSVImportWindowWidth, asCSVImportWindowHeight,
|
||
asCSVImportFilename, asCSVImportFieldsEnclosedOptionally, asCSVImportIgnoreLines, asCSVImportLowPriority, asCSVImportLocalNumbers,
|
||
asCSVImportDuplicateHandling, asCSVImportParseMethod, asCSVKeepDialogOpen,
|
||
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, asSessionManagerListFoldersAtTop, asSessionManagerWindowWidth, asSessionManagerWindowHeight, asSessionManagerWindowLeft, asSessionManagerWindowTop,
|
||
asCopyTableWindowHeight, asCopyTableWindowWidth, asCopyTableColumns, asCopyTableKeys, asCopyTableForeignKeys,
|
||
asCopyTableData, asCopyTableRecentFilter, asServerVersion, asServerVersionFull, asLastConnect,
|
||
asConnectCount, asRefusedCount, asSessionCreated, asDoUsageStatistics,
|
||
asLastUsageStatisticCall, asWheelZoom, asDisplayBars, asMySQLBinaries, asTerminal, asCustomSnippetsDirectory,
|
||
asPromptSaveFileOnTabClose, asRestoreTabs, asTabCloseOnDoubleClick, asTabCloseOnMiddleClick, asTabsInMultipleLines, asTabIconsGrayscaleMode,
|
||
asWarnUnsafeUpdates, 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, asFileDialogPreviousDir,
|
||
asThemePreviewWidth, asThemePreviewHeight, asThemePreviewTop, asThemePreviewLeft,
|
||
asCreateDbCollation, asRealTrailingZeros,
|
||
asSequalSuggestWindowWidth, asSequalSuggestWindowHeight, asSequalSuggestPrompt, asSequalSuggestRecentPrompts,
|
||
asReformatter, asReformatterNoDialog, asAlwaysGenerateFilter,
|
||
asGenerateDataNumRows, asGenerateDataNullAmount, asWebOnceAction,
|
||
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;
|
||
FSessionPath: String;
|
||
FStoredPath: String;
|
||
FRegistry: TJsonRegistry;
|
||
FPortableMode: Boolean;
|
||
FRestoreTabsInitValue: Boolean;
|
||
FSettings: Array[TAppSettingIndex] of TAppSetting;
|
||
FDirnameUserAppData: String;
|
||
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; out I: Integer; out B: Boolean; out S: String;
|
||
DI: Integer; DB: Boolean; DS: String);
|
||
procedure Write(Index: TAppSettingIndex; FormatName: String;
|
||
DataType: TAppSettingDataType; I: Integer; B: Boolean; S: String);
|
||
public
|
||
const PathDelimiter = '/';
|
||
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 Writes: Integer read FWrites;
|
||
function ConvertWindowsToLinuxPath(Path: String): String;
|
||
procedure ImportSettings(Filename: String);
|
||
function ExportSettings(Filename: String): Boolean;
|
||
// 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;
|
||
function AppendDelimiter(Path: String): String;
|
||
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 isUnicode(str: String): Boolean;
|
||
function encryptUnicode(str: String): String;
|
||
function decryptUnicode(str: String): 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;
|
||
procedure StripNewLines(var txt: String; Replacement: String=' ');
|
||
function GetLineBreak(LineBreakIndex: TLineBreaks): String;
|
||
procedure RemoveNullChars(var Text: String; var HasNulls: Boolean);
|
||
// Replace special characters in a filename with underscore
|
||
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; MilliSecondsPrecision: Integer=1): String;
|
||
// Return directory of running executable, including a trailing path delimiter
|
||
function GetAppDir: String;
|
||
// Return directory with dlls or dylibs, or empty string for auto-detection
|
||
function GetLibDir: String;
|
||
// Return directory with MySQL plugin files. Empty on Linux inidicating auto-detection.
|
||
function GetPluginDir: String;
|
||
// Point to Resources dir in macOS app bundle, application dir in most other OSes
|
||
function GetResourcesDir: String;
|
||
procedure SaveUnicodeFile(Filename: String; Text: String; Encoding: TEncoding);
|
||
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);
|
||
function WideHexToBin(text: String): AnsiString;
|
||
function BinToWideHex(bin: AnsiString): String;
|
||
procedure FixVT(VT: TVirtualStringTree; IsResultGrid: Boolean=False);
|
||
function GetTextHeight(Font: TFont): Integer;
|
||
function ColorAdjustBrightness(Col: TColor; Shift: SmallInt): TColor;
|
||
procedure DeInitializeVTNodes(Sender: TBaseVirtualTree);
|
||
function FindNode(VT: TLazVirtualStringTree; idx: Int64; ParentNode: PVirtualNode): PVirtualNode;
|
||
function SelectNode(VT: TLazVirtualStringTree; idx: Int64; ParentNode: PVirtualNode=nil): Boolean; overload;
|
||
function SelectNode(VT: TLazVirtualStringTree; 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: TLazVirtualStringTree; CurrentNode: PVirtualNode; Selected: Boolean=False): PVirtualNode;
|
||
function GetPreviousNode(Tree: TLazVirtualStringTree; 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 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: TLazVirtualStringTree; 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 GetFileModTime(const FileName: string): TDateTime;
|
||
function IsEmpty(Str: String): Boolean;
|
||
function IsNotEmpty(Str: String): Boolean;
|
||
function IfEmpty(Str: String; WhenEmpty: String): String;
|
||
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): String;
|
||
function GetHTMLCharsetByEncoding(Encoding: TEncoding): String;
|
||
procedure ParseCommandLine(CommandLine: String; var ConnectionParams: TConnectionParameters; var FileNames: TStringList; var RunFrom: String);
|
||
procedure InitMoFile(LangCode: String);
|
||
function _(const Pattern: string): string;
|
||
function f_(const Pattern: string; const Args: array of const): string;
|
||
function GetOutputFilename(FilenameWithPlaceholders: String; DBObj: TDBObject): String;
|
||
function GetOutputFilenamePlaceholders: TStringList;
|
||
function GetExecutableBits: Byte;
|
||
procedure Help(Sender: TObject; Anchor: String);
|
||
function IsPortFree(APort: Word; const AIP: string = '127.0.0.1'): Boolean;
|
||
function GetThemeColor(Color: TColor): TColor;
|
||
function ThemeIsDark(ThemeName: String=''): Boolean;
|
||
function ProcessExists(pid: Cardinal; ExeNamePattern: String): Boolean;
|
||
function SynCompletionProposalPrettyText(ImageIndex: Integer; LeftText, CenterText, RightText: String; LeftColor: TColor=-1; CenterColor: TColor=-1; RightColor: TColor=-1): String;
|
||
function PopupComponent(Sender: TObject): TComponent;
|
||
procedure FindComponentInstances(BaseForm: TComponent; ClassType: TClass; var List: TObjectList<TComponent>);
|
||
function GetOS: String;
|
||
function UserAgent(OwnerComponent: TComponent): String;
|
||
function CodeIndent(Steps: Integer=1): String;
|
||
function EscapeHotkeyPrefix(Text: String): String;
|
||
function GetFileNameWithoutExtension(Filename: String): String;
|
||
function GetCommandLine: String;
|
||
// This returns a stable, lowercase name "heidisql", used for configuration files and translations
|
||
function GetApplicationName: String;
|
||
procedure CopyImageList(SourceList, TargetList: TImageList; AppendDisabled: Boolean);
|
||
|
||
var
|
||
AppSettings: TAppSettings;
|
||
AppLanguageMoFile: TMOFile;
|
||
AppLanguageMoBasePath: String;
|
||
MutexHandle: THandle = 0;
|
||
SystemImageList: TImageList = nil;
|
||
mtCriticalConfirmation: TMsgDlgType = mtWarning;
|
||
//ConfirmIcon: TIcon;
|
||
NumberChars: TSysCharSet;
|
||
LibHandleUser32: THandle;
|
||
UTF8NoBOMEncoding: TUTF8NoBOMEncoding;
|
||
DateTimeNever: TDateTime;
|
||
|
||
implementation
|
||
|
||
uses main;
|
||
|
||
|
||
|
||
function WideHexToBin(text: String): AnsiString;
|
||
var
|
||
buf: AnsiString;
|
||
begin
|
||
buf := AnsiString(text);
|
||
Result := '';
|
||
SetLength(Result, Length(text) div 2);
|
||
HexToBin(PAnsiChar(buf), @Result[1], Length(Result));
|
||
end;
|
||
|
||
function BinToWideHex(bin: AnsiString): String;
|
||
var
|
||
buf: AnsiString;
|
||
begin
|
||
buf := '';
|
||
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;
|
||
|
||
|
||
|
||
{***
|
||
Check if string is Unicode
|
||
|
||
@param string String to check
|
||
@return boolean
|
||
}
|
||
function isUnicode(str: String): Boolean;
|
||
var i: integer;
|
||
begin
|
||
result := false;
|
||
for i := 1 to length(str) do begin
|
||
result := ord(str[i]) > 255;
|
||
if result then exit;
|
||
end;
|
||
end;
|
||
|
||
|
||
{***
|
||
Password-encryption, used to store session-passwords in registry
|
||
Unicode (UTF-16) version, support up to 0xFFFF
|
||
|
||
@param string Text to encrypt
|
||
@return string Encrypted Text
|
||
}
|
||
function encryptUnicode(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) mod 65536;
|
||
h := IntToHex(nr, 4); // 4 hex-symbols
|
||
result := result + h;
|
||
end;
|
||
// Adding Unicode flag
|
||
result := result + IntToStr(salt) + '0';
|
||
end;
|
||
|
||
|
||
{***
|
||
Password-decryption, used to restore session-passwords from registry
|
||
Unicode (UTF-16) version, support up to 0xFFFF
|
||
|
||
@param string Text to decrypt
|
||
@return string Decrypted Text
|
||
}
|
||
function decryptUnicode(str: String): String;
|
||
var
|
||
j, salt, nr: integer;
|
||
begin
|
||
result := '';
|
||
if str = '' then exit;
|
||
salt := StrToIntDef(str[length(str)], -1);
|
||
|
||
// Salt is NAN
|
||
if salt < 0 then exit;
|
||
|
||
j := 1;
|
||
while j < length(str) do begin
|
||
nr := StrToInt('$' + copy(str, j, 4)) - salt;
|
||
if nr < 0 then
|
||
nr := nr + 65536;
|
||
result := result + chr(nr);
|
||
inc(j, 4);
|
||
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
|
||
if isUnicode(str) then begin
|
||
result := encryptUnicode(str);
|
||
exit;
|
||
end;
|
||
|
||
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;
|
||
salt := StrToIntDef(str[length(str)], -1);
|
||
|
||
// Salt is NAN - error
|
||
if salt < 0 then exit;
|
||
|
||
// Salt is Unicode flag - Unicode logic
|
||
if salt = 0 then begin
|
||
// Removing Unicode flag
|
||
result := decryptUnicode(copy(str, 1, length(str) - 1));
|
||
exit;
|
||
end;
|
||
|
||
// Salt is... salt - ANSI logic
|
||
j := 1;
|
||
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
|
||
}
|
||
function _GetFileSize(Filename: String): Int64;
|
||
begin
|
||
Result := FileSize(Filename);
|
||
end;
|
||
|
||
|
||
function DeleteFileWithUndo(sFileName: string): Boolean;
|
||
begin
|
||
// Todo: move to trash, cross-platform
|
||
Result := SysUtils.DeleteFile(sFileName);
|
||
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;
|
||
|
||
procedure StripNewLines(var txt: String; Replacement: String=' ');
|
||
begin
|
||
txt := StringReplace(txt, #13#10, Replacement, [rfReplaceAll]);
|
||
txt := StringReplace(txt, #13, Replacement, [rfReplaceAll]);
|
||
txt := StringReplace(txt, #10, Replacement, [rfReplaceAll]);
|
||
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;
|
||
|
||
|
||
function ValidFilename(Str: String): String;
|
||
const
|
||
InvalidFileNameChars: set of Char = {$IFDEF WINDOWS}
|
||
[#0..#31, '"', '*', '/', ':', '<', '>', '?', '\', '|'];
|
||
{$ELSE}
|
||
[#0, '/', ':'];
|
||
{$ENDIF}
|
||
var
|
||
c: Char;
|
||
begin
|
||
Result := Str;
|
||
for c in InvalidFileNameChars 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;
|
||
|
||
|
||
{***
|
||
Execute system command
|
||
Don't use for opening URL
|
||
}
|
||
procedure ShellExec(cmd: String; path: String=''; params: String=''; RunHidden: Boolean=False);
|
||
var
|
||
Msg: String;
|
||
ShowOptions: TShowWindowOptions;
|
||
ProcessResult: String;
|
||
begin
|
||
if ExecRegExprI('^https?\://', cmd) then begin
|
||
LCLIntf.OpenURL(cmd);
|
||
Exit;
|
||
end;
|
||
if RunHidden then
|
||
ShowOptions := swoHIDE
|
||
else
|
||
ShowOptions := swoNone;
|
||
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);
|
||
Process.RunCommandInDir(path, cmd, [params], ProcessResult, [], ShowOptions);
|
||
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.7
|
||
}
|
||
function FormatTimeNumber(Seconds: Double; DisplaySeconds: Boolean; MilliSecondsPrecision: Integer=1): String;
|
||
var
|
||
d, h, m, s, ms: Integer;
|
||
msStr: String;
|
||
begin
|
||
s := TruncDef(Seconds, 0);
|
||
ms := TruncDef((Seconds - s) * Power(10, MilliSecondsPrecision), 0); // Milliseconds, with variable precision/digits
|
||
msStr := IntToStr(ms).PadLeft(MilliSecondsPrecision, '0');
|
||
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 + '.' + msStr; // Append milliseconds
|
||
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 + '.' + msStr; // Append milliseconds
|
||
end
|
||
else begin
|
||
Result := Format('%.2d:%.2d h', [h, m]);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
function GetAppDir: String;
|
||
begin
|
||
Result := ExtractFilePath(Application.ExeName);
|
||
end;
|
||
|
||
function GetLibDir: String;
|
||
begin
|
||
{$IFDEF WINDOWS}
|
||
Result := GetAppDir;
|
||
{$ENDIF}
|
||
{$IFDEF DARWIN}
|
||
Result := GetAppDir + '..' + DirectorySeparator + 'Frameworks' + DirectorySeparator;
|
||
{$ENDIF}
|
||
{$IFDEF LINUX}
|
||
Result := '';
|
||
{$ENDIF}
|
||
{$IFDEF FREEBSD}
|
||
Result := '';
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function GetPluginDir: String;
|
||
begin
|
||
// Windows: reuse plugin directory from pre-v13 installations
|
||
// Linux: return empty string, indicating libmysql knows where to look at
|
||
// macOS: use the Frameworks directory, where all other libs reside
|
||
Result := GetLibDir;
|
||
{$IFDEF WINDOWS}
|
||
Result := Result + 'plugins' + DirectorySeparator;
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function GetResourcesDir: String;
|
||
begin
|
||
Result := GetAppDir;
|
||
{$IFDEF DARWIN}
|
||
Result := GetAppDir + '..' + DirectorySeparator + 'Resources' + DirectorySeparator;
|
||
{$ENDIF}
|
||
{$IFDEF FREEBSD}
|
||
Result := '/usr/local/share/heidisql/';
|
||
{$ENDIF}
|
||
end;
|
||
|
||
{**
|
||
Save a textfile with unicode
|
||
}
|
||
procedure SaveUnicodeFile(Filename: String; Text: String; Encoding: TEncoding);
|
||
var
|
||
Writer: TFileStream;
|
||
Bytes: TBytes;
|
||
begin
|
||
// Encoding may be nil when previously loaded via auto-detection
|
||
if not Assigned(Encoding) then
|
||
Encoding := UTF8NoBOMEncoding;
|
||
Bytes := Encoding.GetBytes(Text); // Encode text
|
||
Writer := TFileStream.Create(Filename, fmCreate);
|
||
try
|
||
Writer.WriteBuffer(Bytes[0], Length(Bytes));
|
||
finally
|
||
Writer.Free;
|
||
end;
|
||
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
|
||
Header := [];
|
||
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. Result can be:
|
||
UTF-16 BE with BOM
|
||
UTF-16 LE with BOM
|
||
UTF-8 with or without BOM
|
||
}
|
||
function DetectEncoding(Stream: TStream): TEncoding;
|
||
const
|
||
BOM_UTF8: array[0..2] of Byte = ($EF, $BB, $BF);
|
||
BOM_UTF16LE: array[0..1] of Byte = ($FF, $FE);
|
||
BOM_UTF16BE: array[0..1] of Byte = ($FE, $FF);
|
||
var
|
||
Buffer: array[0..3] of Byte;
|
||
ReadCount: Integer;
|
||
OldPos: Int64;
|
||
begin
|
||
Result := UTF8NoBOMEncoding; // Default if no BOM is found
|
||
|
||
OldPos := Stream.Position;
|
||
Stream.Position := 0;
|
||
try
|
||
ReadCount := Stream.Read({%H-}Buffer, SizeOf(Buffer));
|
||
finally
|
||
Stream.Position := OldPos;
|
||
end;
|
||
|
||
if (ReadCount >= 3) and CompareMem(@Buffer[0], @BOM_UTF8[0], 3) then
|
||
Result := TEncoding.UTF8
|
||
else if (ReadCount >= 2) and CompareMem(@Buffer[0], @BOM_UTF16LE[0], 2) then
|
||
Result := TEncoding.Unicode // UTF-16 LE
|
||
else if (ReadCount >= 2) and CompareMem(@Buffer[0], @BOM_UTF16BE[0], 2) then
|
||
Result := TEncoding.BigEndianUnicode // UTF-16 BE
|
||
// Could add detection for UTF-32 BOMs too if needed
|
||
else
|
||
Result := UTF8NoBOMEncoding; // No BOM
|
||
end;
|
||
|
||
|
||
function ReadTextfileChunk(Stream: TFileStream; Encoding: TEncoding; ChunkSize: Int64 = 0): String;
|
||
var
|
||
DataLeft: Int64;
|
||
Bytes: TBytes;
|
||
begin
|
||
// Read a chunk or the complete contents out of a textfile, opened by OpenTextFile()
|
||
if Stream.Size = 0 then begin
|
||
Result := '';
|
||
Exit;
|
||
end;
|
||
|
||
DataLeft := Stream.Size - Stream.Position;
|
||
if (ChunkSize = 0) or (ChunkSize > DataLeft) then
|
||
ChunkSize := DataLeft;
|
||
|
||
Bytes := [];
|
||
SetLength(Bytes, ChunkSize);
|
||
Stream.ReadBuffer(Bytes[0], Length(Bytes));
|
||
Result := Encoding.GetAnsiString(Bytes);
|
||
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;
|
||
Result := '';
|
||
SetLength(Result, MaxBytes);
|
||
Stream.Read(PAnsiChar(Result)^, Length(Result));
|
||
Stream.Free;
|
||
end;
|
||
|
||
|
||
procedure StreamToClipboard(Text, HTML: TStream);
|
||
var
|
||
TextContent, HTMLContent: String;
|
||
begin
|
||
// Copy unicode text to clipboard
|
||
TextContent := '';
|
||
HTMLContent := '';
|
||
if Assigned(Text) then begin
|
||
SetLength(TextContent, Text.Size);
|
||
Text.Position := 0;
|
||
Text.Read(PChar(TextContent)^, Length(TextContent));
|
||
end;
|
||
if Assigned(HTML) then begin
|
||
SetLength(HTMLContent, HTML.Size);
|
||
HTML.Position := 0;
|
||
HTML.Read(PChar(HTMLContent)^, Length(HTMLContent));
|
||
end;
|
||
Clipboard.SetAsHtml(HTMLContent, TextContent);
|
||
end;
|
||
|
||
|
||
procedure FixVT(VT: TVirtualStringTree; IsResultGrid: Boolean=False);
|
||
var
|
||
SingleLineHeight, MultiLineCount: Integer;
|
||
Node: PVirtualNode;
|
||
begin
|
||
// This is called either in some early stage (and probably from preferences/apply button?)
|
||
SingleLineHeight := GetTextHeight(VT.Font) + 7;
|
||
// Multiline nodes?
|
||
if IsResultGrid then
|
||
MultiLineCount := AppSettings.ReadInt(asGridRowLineCount)
|
||
else
|
||
MultiLineCount := 1;
|
||
// Issue #2344: TBaseVirtualTree.UpdateVerticalRange crashes with ERangeError on ArchLinux
|
||
// due to FRangeY/Cardinal getting a negative value.
|
||
// Happening when DefaultNodeHeight is set and then with 0 nodes in data grid
|
||
// Once the form files are back at 96 PPI this should no longer crash.
|
||
{$IFNDEF LINUX}
|
||
VT.DefaultNodeHeight := SingleLineHeight * MultiLineCount;
|
||
{$ENDIF}
|
||
if MultiLineCount > 1 then begin
|
||
VT.BeginUpdate;
|
||
Node := VT.GetFirstInitialized;
|
||
while Assigned(Node) do begin
|
||
// Nodes have vsMultiLine through InitNode event
|
||
VT.MultiLine[Node] := MultiLineCount > 1;
|
||
Node := VT.GetNextInitialized(Node);
|
||
end;
|
||
VT.EndUpdate;
|
||
end;
|
||
{$IFNDEF WINDOWS}
|
||
// Disable grid lines, looks ok on Windows with dotted light lines, but not on macOS and Linux
|
||
if (toHotTrack in VT.TreeOptions.PaintOptions) then
|
||
VT.TreeOptions.PaintOptions := VT.TreeOptions.PaintOptions - [toShowHorzGridLines, toShowVertGridLines];
|
||
{$ENDIF}
|
||
VT.OnGetHint := MainForm.AnyGridGetHint;
|
||
VT.OnScroll := MainForm.AnyGridScroll;
|
||
VT.OnMouseWheel := MainForm.AnyGridMouseWheel;
|
||
VT.ShowHint := True;
|
||
|
||
if IsResultGrid then begin
|
||
VT.HintMode := hmHint; // Show cell contents with linebreakds in datagrid and querygrid's
|
||
if AppSettings.ReadBool(asIncrementalSearch) then begin
|
||
// Apply case insensitive incremental search event
|
||
VT.IncrementalSearch := isInitializedOnly;
|
||
VT.OnIncrementalSearch := Mainform.AnyGridIncrementalSearch;
|
||
end
|
||
else begin
|
||
VT.IncrementalSearch := isNone;
|
||
end;
|
||
end
|
||
else
|
||
VT.HintMode := hmTooltip; // Just a quick tooltip for clipped nodes
|
||
VT.OnStartOperation := Mainform.AnyGridStartOperation;
|
||
VT.OnEndOperation := Mainform.AnyGridEndOperation;
|
||
end;
|
||
|
||
|
||
function GetTextHeight(Font: TFont): Integer;
|
||
var
|
||
Bmp: Graphics.TBitmap;
|
||
begin
|
||
Bmp := Graphics.TBitmap.Create;
|
||
Bmp.Canvas.Font.Name := Font.Name;
|
||
Bmp.Canvas.Font.Size := Font.Size;
|
||
Result := Bmp.Canvas.TextHeight('<27>y');
|
||
Bmp.Free;
|
||
end;
|
||
|
||
|
||
function ColorAdjustBrightness(Col: TColor; Shift: SmallInt): TColor;
|
||
var
|
||
H, L, S: 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
|
||
ColorToHLS(Col, H, L, S);
|
||
if (L < 128) and (Shift < 0) then
|
||
Shift := Abs(Shift)
|
||
else if (L > 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: TLazVirtualStringTree; 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: TLazVirtualStringTree; 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: TLazVirtualStringTree; Node: PVirtualNode; ClearSelection: Boolean=True): Boolean; overload;
|
||
var
|
||
OldFocus: PVirtualNode;
|
||
MinimumColumnIndex: TColumnIndex;
|
||
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;
|
||
MinimumColumnIndex := VT.Header.Columns.GetFirstVisibleColumn(True);
|
||
if VT.FocusedColumn < MinimumColumnIndex then
|
||
VT.FocusedColumn := MinimumColumnIndex;
|
||
VT.Selected[Node] := True;
|
||
VT.ScrollIntoView(Node, False);
|
||
if (OldFocus = Node) and Assigned(VT.OnFocusChanged) then
|
||
VT.OnFocusChanged(VT, Node, VT.FocusedColumn);
|
||
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: TLazVirtualStringTree; 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;
|
||
|
||
|
||
|
||
{ *** 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;
|
||
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);
|
||
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.ImageListMain;
|
||
|
||
Item := TMenuItem.Create(popup);
|
||
Item.Action := MainForm.actCopy;
|
||
popup.Items.Add(Item);
|
||
|
||
Item := TMenuItem.Create(popup);
|
||
Item.Action := MainForm.actCut;
|
||
popup.Items.Add(Item);
|
||
|
||
Item := TMenuItem.Create(popup);
|
||
Item.Action := MainForm.actPaste;
|
||
popup.Items.Add(Item);
|
||
|
||
Item := TMenuItem.Create(popup);
|
||
Item.Action := MainForm.actSelectAll;
|
||
popup.Items.Add(Item);
|
||
|
||
Item := TMenuItem.Create(popup);
|
||
Item.Action := MainForm.actSaveSynMemoToTextfile;
|
||
popup.Items.Add(Item);
|
||
|
||
Item := TMenuItem.Create(popup);
|
||
Item.Action := MainForm.actToggleComment;
|
||
popup.Items.Add(Item);
|
||
|
||
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
|
||
// Windows-only. Prefer "ssShift in GetKeyShiftState"
|
||
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
|
||
Result := '';
|
||
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: TLazVirtualStringTree; RefreshTag: Integer; ImmediateRepaint: Boolean);
|
||
begin
|
||
// Avoid AVs in OnDestroy events
|
||
if not Assigned(VT) then
|
||
Exit;
|
||
VT.Tag := RefreshTag;
|
||
if ImmediateRepaint then begin
|
||
VT.Repaint;
|
||
VT.Update;
|
||
end
|
||
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, loUserLocale);
|
||
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 modification date/time from passed file name
|
||
function GetFileModTime(const FileName: string): TDateTime;
|
||
var
|
||
L: LongInt;
|
||
begin
|
||
L := FileAge(FileName); // returns DOS date/time as LongInt, or -1 on error
|
||
if L <> -1 then
|
||
Result := FileDateToDateTime(L)
|
||
else
|
||
Result := 0;
|
||
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 IfEmpty(Str: String; WhenEmpty: String): String;
|
||
begin
|
||
if Str.IsEmpty then
|
||
Result := WhenEmpty
|
||
else
|
||
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
|
||
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 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
|
||
|
||
{$IFNDEF WINDOWS}
|
||
if (KeepAskingSetting = asUnused) and (FooterText.IsEmpty) then begin
|
||
// Show the more native MessageDlg when we don't need additional dialog features.
|
||
// Especially useful on macOS and Linux where the TTaskDialog looks really different than MessageDlg.
|
||
Result := MessageDlg(Title, Msg, DlgType, Buttons, 0);
|
||
Exit;
|
||
end;
|
||
{$ENDIF}
|
||
|
||
// Remember current path and restore it later, so the caller does not try to read from the wrong path after this dialog
|
||
AppSettings.StorePath;
|
||
|
||
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"]+';
|
||
if ThemeIsDark then
|
||
Dialog.Text := Msg
|
||
else // See issue #2036
|
||
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.MainIcon := tdiQuestion;
|
||
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;
|
||
|
||
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): String;
|
||
var
|
||
Buffer: array[0..255] of WideChar;
|
||
WS: UnicodeString;
|
||
BufferLen: Integer;
|
||
begin
|
||
Result := '';
|
||
{$IFDEF WINDOWS}
|
||
if LibHandleUser32 <> 0 then begin
|
||
BufferLen := LoadStringW(LibHandleUser32, ResourceId, {%H-}Buffer, Length(Buffer));
|
||
if BufferLen > 0 then begin
|
||
SetString(WS, PWideChar(@Buffer[0]), BufferLen);
|
||
Result := UTF16ToUTF8(WS);
|
||
end;
|
||
end;
|
||
{$ENDIF}
|
||
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,
|
||
SshExe, SshHost, SshPort, SshLocalPort, SshUser, SshPassword, SshKey, SshTimeout: String;
|
||
NetType, WindowsAuth, WantSSL, CleartextPluginEnabled, SSLVerification: 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\=]\"([^\"]+)\"';
|
||
if rx.Exec(CommandLine) then
|
||
Result := rx.Match[2]
|
||
else begin
|
||
rx.Expression := '\s(\-'+ShortName+'|\-\-'+LongName+')[\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');
|
||
SSLVerification := StrToIntDef(GetParamValue('sslvrf', 'sslverification'), -1);
|
||
// Leave out support for startup script, seems reasonable for command line connecting
|
||
SshExe := GetParamValue('se', 'ssh-executable');
|
||
SshHost := GetParamValue('sh', 'ssh-host');
|
||
SshPort := GetParamValue('sP', 'ssh-port');
|
||
SshLocalPort := GetParamValue('sLP', 'ssh-local-port');
|
||
SshUser := GetParamValue('su', 'ssh-user');
|
||
SshPassword := GetParamValue('sp', 'ssh-password');
|
||
SshKey := GetParamValue('sk', 'ssh-key');
|
||
SshTimeout := GetParamValue('st', 'ssh-timeout');
|
||
|
||
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 SSLVerification >= 0 then
|
||
ConnectionParams.SSLVerification := SSLVerification;
|
||
|
||
if WindowsAuth in [0,1] then
|
||
ConnectionParams.WindowsAuth := Boolean(WindowsAuth);
|
||
|
||
if not SshHost.IsEmpty then begin
|
||
ConnectionParams.SSHActive := True;
|
||
if not SshExe.IsEmpty then
|
||
ConnectionParams.SSHExe := SshExe;
|
||
if not SshHost.IsEmpty then
|
||
ConnectionParams.SSHHost := SshHost;
|
||
if not SshPort.IsEmpty then
|
||
ConnectionParams.SSHPort := StrToIntDef(SshPort, ConnectionParams.SSHPort);
|
||
if not SshLocalPort.IsEmpty then
|
||
ConnectionParams.SSHLocalPort := StrToIntDef(SshLocalPort, ConnectionParams.SSHLocalPort);
|
||
if not SshUser.IsEmpty then
|
||
ConnectionParams.SSHUser := SshUser;
|
||
if not SshPassword.IsEmpty then
|
||
ConnectionParams.SSHPassword := SshPassword;
|
||
if not SshKey.IsEmpty then
|
||
ConnectionParams.SSHPrivateKey := SshKey;
|
||
if not SshTimeout.IsEmpty then
|
||
ConnectionParams.SSHTimeout := StrToIntDef(SshTimeout, ConnectionParams.SSHTimeout);
|
||
end;
|
||
|
||
if ConnectionParams.SessionPath.IsEmpty then begin
|
||
// Ensure we have a (random) session name to pass to InitConnection
|
||
ConnectionParams.SessionPath := IfEmpty(ConnectionParams.Hostname, 'temp')+'-'+GeneratePassword(4);
|
||
end;
|
||
|
||
// Delete stored session in Destroy:
|
||
ConnectionParams.DeleteAfterUse := True;
|
||
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;
|
||
|
||
|
||
procedure InitMoFile(LangCode: String);
|
||
var
|
||
LocaleDir, MOFileName: String;
|
||
begin
|
||
// Initialize .mo file in the given language, so we can use that for translating via _()
|
||
if LangCode.IsEmpty then
|
||
LangCode := SysLanguage;
|
||
LocaleDir := GetResourcesDir + AppendPathDelim('locale');
|
||
AppLanguageMoBasePath := LocaleDir + GetApplicationName;
|
||
MOFileName := '';
|
||
if not LangCode.IsEmpty then begin
|
||
MOFileName := AppLanguageMoBasePath + '.' + LangCode + '.mo';
|
||
if not FileExistsUTF8(MOFileName) then
|
||
MOFileName := '';
|
||
end;
|
||
if MOFileName.IsEmpty then begin
|
||
MOFileName := AppLanguageMoBasePath + '.mo';
|
||
end;
|
||
if FileExistsUTF8(MOFileName) then begin
|
||
AppLanguageMoFile := TMOFile.Create(UTF8ToSys(MOFileName));
|
||
end;
|
||
end;
|
||
|
||
|
||
function _(const Pattern: string): string;
|
||
begin
|
||
Result := '';
|
||
if Assigned(AppLanguageMoFile) then
|
||
Result := AppLanguageMoFile.Translate(Pattern);
|
||
if Result.IsEmpty then
|
||
Result := Pattern;
|
||
end;
|
||
|
||
|
||
function f_(const Pattern: string; const Args: array of const): string;
|
||
var
|
||
TranslatedPattern: String;
|
||
begin
|
||
// Helper for translation, replacement for Format(_())
|
||
try
|
||
TranslatedPattern := _(Pattern);
|
||
Result := Format(TranslatedPattern, Args);
|
||
except
|
||
on E:Exception do begin
|
||
MainForm.LogSQL(E.ClassName+' in translation string with invalid format arguments: "'+TranslatedPattern+'"', lcError);
|
||
Result := Format(Pattern, Args);
|
||
end;
|
||
end;
|
||
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 GetExecutableBits: Byte;
|
||
begin
|
||
{$IfDef CPU32}
|
||
Result := 32;
|
||
{$EndIf}
|
||
{$IfDef CPU64}
|
||
Result := 64;
|
||
{$EndIf}
|
||
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 IsPortFree(APort: Word; const AIP: string = '127.0.0.1'): Boolean;
|
||
var
|
||
s: LongInt;
|
||
addr: TInetSockAddr;
|
||
begin
|
||
Result := False;
|
||
|
||
s := fpSocket(AF_INET, SOCK_STREAM, 0);
|
||
if s < 0 then
|
||
Exit;
|
||
|
||
try
|
||
addr := Default(TInetSockAddr);
|
||
FillChar(addr, SizeOf(addr), 0);
|
||
addr.sin_family := AF_INET;
|
||
addr.sin_port := htons(APort);
|
||
addr.sin_addr := StrToNetAddr(AIP);
|
||
|
||
if fpBind(s, @addr, SizeOf(addr)) = 0 then
|
||
Result := True
|
||
else
|
||
Result := False;
|
||
finally
|
||
CloseSocket(s);
|
||
end;
|
||
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;
|
||
begin
|
||
// Todo: return true if system dark style is in use?
|
||
Result := False;
|
||
end;
|
||
|
||
|
||
function ProcessExists(pid: Cardinal; ExeNamePattern: String): Boolean;
|
||
{var
|
||
Proc: TProcessEntry32;
|
||
SnapShot: THandle;
|
||
ContinueLoop: Boolean;}
|
||
begin
|
||
// Check if a given process id exists
|
||
// Todo: convert code for cross-platforming
|
||
Result := False;
|
||
{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;
|
||
|
||
|
||
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{10}\color{%s}\style{+i}%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;
|
||
|
||
procedure FindComponentInstances(BaseForm: TComponent; ClassType: TClass; var List: TObjectList<TComponent>);
|
||
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])
|
||
else
|
||
FindComponentInstances(BaseForm.Components[i], ClassType, List);
|
||
end;
|
||
end;
|
||
|
||
|
||
function GetOS: String;
|
||
begin
|
||
Result := 'Unknown';
|
||
{$IfDef FreeBSD}
|
||
Result := 'FreeBSD';
|
||
{$EndIf}
|
||
{$IfDef LINUX}
|
||
Result := 'Linux';
|
||
{$EndIf}
|
||
{$IfDef WINDOWS}
|
||
Result := 'Windows';
|
||
{$EndIf}
|
||
{$IfDef DARWIN}
|
||
Result := 'macOS';
|
||
{$EndIf}
|
||
end;
|
||
|
||
function UserAgent(OwnerComponent: TComponent): String;
|
||
begin
|
||
Result := APPNAME+'/'+MainForm.AppVersion+' ('+GetOS+'; '+ExtractFilename(Application.ExeName)+'; '+OwnerComponent.Name+')';
|
||
end;
|
||
|
||
|
||
function CodeIndent(Steps: Integer=1): String;
|
||
begin
|
||
// Provide tab or spaces for indentation, uniquely used for all SQL statements
|
||
if AppSettings.ReadBool(asTabsToSpaces) then
|
||
Result := StringOfChar(' ', AppSettings.ReadInt(asTabWidth) * Steps)
|
||
else
|
||
Result := StringOfChar(#9, Steps);
|
||
end;
|
||
|
||
|
||
function EscapeHotkeyPrefix(Text: String): String;
|
||
begin
|
||
// Issue #1992: Escape ampersand in caption of menus and tabs, preventing underlined hotkey generation
|
||
Result := StringReplace(Text, Menus.cHotkeyPrefix, Menus.cHotkeyPrefix + Menus.cHotkeyPrefix, [rfReplaceAll]);
|
||
end;
|
||
|
||
function GetFileNameWithoutExtension(Filename: String): String;
|
||
var
|
||
LastDotPos: Integer;
|
||
begin
|
||
Result := ExtractFileName(Filename);
|
||
LastDotPos := Result.LastIndexOf('.');
|
||
if LastDotPos > -1 then
|
||
Result := Result.Substring(0, LastDotPos);
|
||
end;
|
||
|
||
function GetCommandLine: String;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
Result := '';
|
||
for i:=0 to ParamCount do begin
|
||
Result := Result + ParamStr(i) + ' ';
|
||
end;
|
||
Result := Trim(Result);
|
||
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;}
|
||
|
||
function GetApplicationName: String;
|
||
begin
|
||
Result := LowerCase(APPNAME);
|
||
end;
|
||
|
||
procedure CopyImageList(SourceList, TargetList: TImageList; AppendDisabled: Boolean);
|
||
var
|
||
i, ResIdx, ResWidth: Integer;
|
||
TempBitmap: Graphics.TBitmap;
|
||
TempBitmapList: Array of TRasterImage;
|
||
const
|
||
Resolutions: Array of Integer = [16, 24, 32, 48];
|
||
begin
|
||
// TImageList.AddImages copies only the current PPI versions of images. Following code copies all resolutions.
|
||
TargetList.Clear;
|
||
TargetList.RegisterResolutions(Resolutions);
|
||
for i:=0 to SourceList.Count-1 do
|
||
begin
|
||
TempBitmapList := [];
|
||
SetLength(TempBitmapList, Length(Resolutions));
|
||
for ResIdx:=Low(Resolutions) to High(Resolutions) do begin
|
||
ResWidth := Resolutions[ResIdx];
|
||
TempBitmap := Graphics.TBitmap.Create;
|
||
SourceList.Resolution[ResWidth].GetBitmap(i, TempBitmap);
|
||
TempBitmapList[ResIdx] := TempBitmap;
|
||
end;
|
||
TargetList.AddMultipleResolutions(TempBitmapList);
|
||
end;
|
||
if AppendDisabled then begin
|
||
for i:=0 to SourceList.Count-1 do
|
||
begin
|
||
SetLength(TempBitmapList, 0);
|
||
SetLength(TempBitmapList, Length(Resolutions));
|
||
for ResIdx:=Low(Resolutions) to High(Resolutions) do begin
|
||
ResWidth := Resolutions[ResIdx];
|
||
TempBitmap := Graphics.TBitmap.Create;
|
||
SourceList.Resolution[ResWidth].GetBitmap(i, TempBitmap, gdeDisabled);
|
||
TempBitmapList[ResIdx] := TempBitmap;
|
||
end;
|
||
TargetList.AddMultipleResolutions(TempBitmapList);
|
||
end;
|
||
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
|
||
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.SetLockedByThread(Self);
|
||
MaxAllowedPacket := FConnection.MaxAllowedPacket;
|
||
FConnection.SetLockedByThread(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(BeforeQuery);
|
||
try
|
||
FConnection.SetLockedByThread(Self);
|
||
DoStoreResult := ResultCount < AppSettings.ReadInt(asMaxQueryResults);
|
||
if (not DoStoreResult) and (not LogMaxResultsDone) then begin
|
||
// Inform user about preference setting for limiting result tabs
|
||
LogFromThread(f_('Reached maximum number of result tabs (%d). To display more results, increase setting in Preferences > SQL', [AppSettings.ReadInt(asMaxQueryResults)]),
|
||
lcInfo
|
||
);
|
||
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) then begin
|
||
FErrorMessage := E.Message;
|
||
ErrorAborted := True;
|
||
end;
|
||
end;
|
||
end;
|
||
FConnection.SetLockedByThread(nil);
|
||
Synchronize(AfterQuery);
|
||
FConnection.ShowWarnings;
|
||
// Check if FAborted is set by the main thread, to avoid proceeding the loop in case
|
||
// FStopOnErrors is set to false
|
||
if FAborted or ErrorAborted then
|
||
break;
|
||
end;
|
||
|
||
Synchronize(BatchFinished);
|
||
end;
|
||
|
||
|
||
procedure TQueryThread.BeforeQuery;
|
||
begin
|
||
MainForm.BeforeQueryExecution(Self);
|
||
end;
|
||
|
||
procedure TQueryThread.LogFromThread(Msg: String; Category: TDBLogCategory);
|
||
begin
|
||
FLogMsg := Msg;
|
||
FLogCategory := Category;
|
||
Synchronize(Log);
|
||
end;
|
||
|
||
|
||
procedure TQueryThread.Log;
|
||
begin
|
||
if Assigned(FConnection.OnLog) then
|
||
FConnection.OnLog(FLogMsg, FLogCategory, FConnection);
|
||
end;
|
||
|
||
|
||
procedure TQueryThread.AfterQuery;
|
||
begin
|
||
MainForm.AfterQueryExecution(Self);
|
||
end;
|
||
|
||
|
||
procedure TQueryThread.BatchFinished;
|
||
begin
|
||
MainForm.FinishedQueryExecution(Self);
|
||
end;
|
||
|
||
|
||
{ TSQLSentence }
|
||
|
||
constructor TSQLSentence.Create(Owner: TSQLBatch);
|
||
begin
|
||
// Use a back reference to the parent batch object, so we can extract SQL from it
|
||
FOwner := Owner;
|
||
end;
|
||
|
||
|
||
function TSQLSentence.GetSize: Integer;
|
||
begin
|
||
Result := RightOffset - LeftOffset;
|
||
end;
|
||
|
||
|
||
function TSQLSentence.GetSQL: String;
|
||
begin
|
||
// Result := Copy(FOwner.SQL, LeftOffset, RightOffset-LeftOffset);
|
||
// 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: Char;
|
||
Delim, DelimTest, QueryTest, LastQuote, cn: String;
|
||
InString, InComment, InBigComment, InEscape: Boolean;
|
||
Marker: TSQLSentence;
|
||
rx: TRegExpr;
|
||
Quotes: THashedStringList;
|
||
const
|
||
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;
|
||
Quotes := THashedStringList.Create;
|
||
Quotes.CaseSensitive := True;
|
||
Quotes.Sorted := True;
|
||
Quotes.Add('"');
|
||
Quotes.Add('''');
|
||
Quotes.Add('`'); // MySQL/MariaDB only
|
||
Quotes.Add('$$'); // PostgreSQL only ($abc$ unsupported)
|
||
|
||
InString := False; // c is in "enclosed string" or `identifier`
|
||
InComment := False; // c is in one-line comment (# or --)
|
||
InBigComment := False; // c is in /* multi-line */ or /*! condictional comment */
|
||
InEscape := False; // Previous char was backslash
|
||
LastQuote := #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;
|
||
cn := c + n;
|
||
|
||
// Check for comment syntax, 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;
|
||
// Check for enclosed literals, so a query delimiter can be ignored
|
||
if (not InEscape) and (not InComment) and (not InBigComment) and (Quotes.Contains(c) or Quotes.Contains(cn)) then begin
|
||
if not InString then begin
|
||
InString := True;
|
||
LastQuote := IfThen(Quotes.Contains(c), c, cn);
|
||
end
|
||
else if (c = LastQuote) or (cn = LastQuote) then begin
|
||
InString := False;
|
||
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;
|
||
|
||
Quotes.Free;
|
||
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 }
|
||
|
||
procedure THttpDownload.SetTimeOut(Value: Cardinal);
|
||
begin
|
||
FTimeOut := Value;
|
||
IOTimeout := Value * 1000;
|
||
end;
|
||
|
||
constructor THttpDownload.Create(Owner: TComponent);
|
||
begin
|
||
inherited;
|
||
AddHeader('User-Agent', UserAgent(Owner));
|
||
end;
|
||
|
||
|
||
procedure THttpDownload.SendRequest(Filename: String);
|
||
begin
|
||
Get(FURL, Filename);
|
||
if ResponseStatusCode <> 200 then
|
||
raise Exception.CreateFmt(_('Got HTTP status %d from %s'), [ResponseStatusCode, FURL]);
|
||
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;
|
||
|
||
|
||
{ TClipboardHelper }
|
||
|
||
function TClipboardHelper.GetTryAsText: String;
|
||
var
|
||
AttemptsLeft: Integer;
|
||
Success: Boolean;
|
||
LastError: String;
|
||
begin
|
||
AttemptsLeft := 5;
|
||
Result := '';
|
||
Success := False;
|
||
while AttemptsLeft > 0 do begin
|
||
Dec(AttemptsLeft);
|
||
try
|
||
Result := AsText;
|
||
Success := True;
|
||
Break;
|
||
except
|
||
// We could also just catch EClipboardException
|
||
on E:Exception do begin
|
||
LastError := E.Message;
|
||
Sleep(100);
|
||
end;
|
||
end;
|
||
end;
|
||
if not Success then
|
||
MainForm.LogSQL(LastError, lcError);
|
||
end;
|
||
|
||
procedure TClipboardHelper.SetTryAsText(AValue: String);
|
||
var
|
||
AttemptsLeft: Integer;
|
||
Success: Boolean;
|
||
LastError: String;
|
||
begin
|
||
AttemptsLeft := 5;
|
||
Success := False;
|
||
while AttemptsLeft > 0 do begin
|
||
Dec(AttemptsLeft);
|
||
try
|
||
AsText := AValue;
|
||
Success := True;
|
||
Break;
|
||
except
|
||
// We could also just catch EClipboardException
|
||
on E:Exception do begin
|
||
LastError := E.Message;
|
||
Sleep(100);
|
||
end;
|
||
end;
|
||
end;
|
||
if not Success then
|
||
MainForm.LogSQL(LastError, lcError);
|
||
end;
|
||
|
||
|
||
procedure TWinControlHelper.TrySetFocus;
|
||
begin
|
||
try
|
||
if Enabled
|
||
and CanFocus then
|
||
SetFocus;
|
||
except
|
||
on E:EInvalidOperation do
|
||
SysUtils.Beep;
|
||
end;
|
||
end;
|
||
|
||
|
||
{ TAppSettings }
|
||
|
||
constructor TAppSettings.Create;
|
||
var
|
||
rx: TRegExpr;
|
||
i: Integer;
|
||
DefaultSnippetsDirectory: String;
|
||
PortableLockFile: String;
|
||
NewFileHandle: THandle;
|
||
begin
|
||
inherited;
|
||
|
||
// Switch to portable mode if lock file exists. File content is ignored.
|
||
PortableLockFile := GetAppDir + FPortableLockFileBase;
|
||
FPortableMode := FileExists(PortableLockFile);
|
||
|
||
// Create and load JSON registry file in user config dir.
|
||
// In the new v13-portable-mode:
|
||
// - DirnameUserAppData points to app dir
|
||
// - --psettings cli argument is ignored / not supported any longer
|
||
// - instead, the settings filename is the same as in non-portable mode (the user may have placed his old portable_settings.txt file here, and we should not overwrite it)
|
||
// - the user once needs to import his old portable_settings.txt after upgrading from pre-v13
|
||
FDirnameUserAppData := '';
|
||
FRegistry := TJsonRegistry.Create(DirnameUserAppData + 'settings.json');
|
||
FReads := 0;
|
||
FWrites := 0;
|
||
|
||
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'+DirectorySeparator+'%session'+DirectorySeparator+'%db'+DirectorySeparator+'%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(asShowRowId, 'ShowRowId', 0, True);
|
||
InitSetting(asHightlightSameTextBackground, 'HightlightSameTextBackground', GetThemeColor(NoteLineBackground));
|
||
InitSetting(asLogsqlnum, 'logsqlnum', 300);
|
||
InitSetting(asLogsqlwidth, 'logsqlwidth', 2000);
|
||
InitSetting(asSessionLogsDirectory, 'SessionLogsDirectory', 0, False, DirnameUserAppData + 'Sessionlogs' + DirectorySeparator);
|
||
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, 'Text', 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(asSSLVerification, 'SSL_Verification', 2, 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', 450);
|
||
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(asGridExportOpenFile, 'GridExportOpenFile', 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', 550);
|
||
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(asCSVKeepDialogOpen, 'CSVKeepDialogOpen', 0, False);
|
||
InitSetting(asUpdatecheck, 'Updatecheck', 0, False);
|
||
// Removed: 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', 300);
|
||
InitSetting(asSessionManagerListFoldersAtTop, 'SessionManager_ListFoldersAtTop', 0, True);
|
||
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, '');
|
||
InitSetting(asTerminal, 'Terminal', 0, False, '');
|
||
InitSetting(asSequalSuggestWindowWidth, 'SequalSuggestWindowWidth', 500);
|
||
InitSetting(asSequalSuggestWindowHeight, 'SequalSuggestWindowHeight', 400);
|
||
InitSetting(asSequalSuggestPrompt, 'SequalSuggestPrompt', 0, False, '');
|
||
InitSetting(asSequalSuggestRecentPrompts, 'SequalSuggestRecentPrompts', 0, False, '');
|
||
InitSetting(asReformatter, 'Reformatter', 0);
|
||
InitSetting(asReformatterNoDialog, 'ReformatterNoDialog', 0);
|
||
InitSetting(asAlwaysGenerateFilter, 'AlwaysGenerateFilter', 0, False);
|
||
InitSetting(asGenerateDataNumRows, 'GenerateDataNumRows', 1000);
|
||
InitSetting(asGenerateDataNullAmount, 'GenerateDataNullAmount', 10);
|
||
|
||
// Default folder for snippets
|
||
DefaultSnippetsDirectory := DirnameUserDocuments + 'Snippets' + DirectorySeparator;
|
||
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, True);
|
||
InitSetting(asTabCloseOnDoubleClick, 'TabCloseOnDoubleClick', 0, True);
|
||
InitSetting(asTabCloseOnMiddleClick, 'TabCloseOnMiddleClick', 0, True);
|
||
InitSetting(asTabsInMultipleLines, 'TabsInMultipleLines', 0, True);
|
||
InitSetting(asTabIconsGrayscaleMode, 'TabIconsGrayscaleMode', 1);
|
||
InitSetting(asWarnUnsafeUpdates, 'WarnUnsafeUpdates', 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); // No longer used
|
||
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(asFileDialogPreviousDir, 'FileDialogPreviousDir', 0, False, '');
|
||
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);
|
||
InitSetting(asWebOnceAction, 'WebOnceAction', 0, False, DateToStr(DateTimeNever));
|
||
|
||
// Initialization values
|
||
FRestoreTabsInitValue := ReadBool(asRestoreTabs);
|
||
|
||
end;
|
||
|
||
|
||
destructor TAppSettings.Destroy;
|
||
begin
|
||
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 := PathDelimiter;
|
||
if FSessionPath <> '' then
|
||
Folder := Folder + AppendDelimiter(REGKEY_SESSIONS) + FSessionPath;
|
||
if PathDelimiter+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 := AppendDelimiter(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 := AppendDelimiter(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(PathDelimiter + AppendDelimiter(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; out I: Integer; out B: Boolean; out 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
|
||
// take a forms DesignTimePPI into account
|
||
Result := ReadInt(Index, FormatName, Default);
|
||
Result := AControl.ScaleDesignToForm(Result);
|
||
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 := AControl.ScaleFormToDesign(Value);
|
||
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 := PathDelimiter + AppendDelimiter(REGKEY_SESSIONS) + ParentPath;
|
||
FRegistry.OpenKey(CurPath, True);
|
||
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(AppendDelimiter(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+AppendDelimiter(Folders[i]), Sessions);
|
||
Sessions.Sort;
|
||
Names.Free;
|
||
Folders.Free;
|
||
end;
|
||
|
||
|
||
function TAppSettings.ConvertWindowsToLinuxPath(Path: String): String;
|
||
var
|
||
rx: TRegExpr;
|
||
begin
|
||
// C:\Users\xyz\AppData\Roaming\HeidiSQL\ => /home/xyz/.config/heidisql/
|
||
Result := Path;
|
||
rx := TRegExpr.Create('^C\:\\Users\\[^\\]+\\AppData\\Roaming\\'+APPNAME+'\\');
|
||
rx.ModifierI := True;
|
||
if rx.Exec(Path) then begin
|
||
Result := Copy(Path, rx.MatchLen[0]+1, SIZE_KB);
|
||
Result := StringReplace(Result, '\', '/', [rfReplaceAll]);
|
||
Result := AppSettings.DirnameUserAppData + Result;
|
||
end;
|
||
rx.Free;
|
||
end;
|
||
|
||
|
||
procedure TAppSettings.ImportSettings(Filename: String);
|
||
var
|
||
Content, Name, Value, KeyPath: String;
|
||
Lines, Segments: TStringList;
|
||
i: Integer;
|
||
DataType: Integer;
|
||
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(LINEDELIMITER, Lines[i]);
|
||
if Segments.Count <> 3 then
|
||
continue;
|
||
// Windows registry to JSON path delimiter conversion: \ => /
|
||
Segments[0] := StringReplace(Segments[0], '\', PathDelimiter, [rfReplaceAll]);
|
||
KeyPath := PathDelimiter + ExtractFilePath(Segments[0]);
|
||
Name := ExtractFileName(Segments[0]);
|
||
DataType := StrToIntDef(Segments[1], 0);
|
||
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
|
||
1: begin // String
|
||
Value := StringReplace(Value, CHR13REPLACEMENT, #13, [rfReplaceAll]);
|
||
Value := StringReplace(Value, CHR10REPLACEMENT, #10, [rfReplaceAll]);
|
||
{$IfDef UNIX}
|
||
Value := ConvertWindowsToLinuxPath(Value);
|
||
{$EndIf}
|
||
FRegistry.WriteString(Name, Value);
|
||
end;
|
||
3: // Integer (Delphi definition)
|
||
FRegistry.WriteInteger(Name, MakeInt(Value));
|
||
else
|
||
ErrorDialog(Name+' has an unsupported data type.');
|
||
end;
|
||
Segments.Free;
|
||
end;
|
||
Lines.Free;
|
||
FRegistry.FlushToDisk;
|
||
end;
|
||
|
||
|
||
function TAppSettings.ExportSettings(Filename: String): Boolean;
|
||
var
|
||
Content, Value: String;
|
||
DataType: TJSONtype; // (jtUnknown, jtNumber, jtString, jtBoolean, jtNull, jtArray, jtObject);
|
||
DataTypeInt: Integer;
|
||
|
||
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(PathDelimiter)+1, MaxInt);
|
||
// JSON to Windows registry path delimiter conversion: / => \
|
||
SubPath := StringReplace(SubPath, PathDelimiter, '\', [rfReplaceAll]);
|
||
Names := TStringList.Create;
|
||
FRegistry.GetValueNames(Names);
|
||
for i:=0 to Names.Count-1 do begin
|
||
DataType := FRegistry.GetDataType(Names[i]);
|
||
// string: 1, int: 3
|
||
DataTypeInt := IfThen(DataType = jtString, 1, 3);
|
||
Content := Content +
|
||
SubPath + Names[i] + LINEDELIMITER +
|
||
DataTypeInt.ToString + LINEDELIMITER;
|
||
case DataType of
|
||
jtString, jtNull: begin
|
||
Value := FRegistry.ReadString(Names[i]);
|
||
Value := StringReplace(Value, #13, CHR13REPLACEMENT, [rfReplaceAll]);
|
||
Value := StringReplace(Value, #10, CHR10REPLACEMENT, [rfReplaceAll]);
|
||
end;
|
||
jtNumber, jtBoolean:
|
||
Value := IntToStr(FRegistry.ReadInteger(Names[i]));
|
||
else
|
||
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] + PathDelimiter);
|
||
Names.Free;
|
||
end;
|
||
|
||
begin
|
||
// Save registry settings to file
|
||
Content := '';
|
||
ReadKeyToContent(PathDelimiter);
|
||
SaveUnicodeFile(FileName, Content, UTF8NoBOMEncoding);
|
||
Result := True;
|
||
end;
|
||
|
||
|
||
// Base folder for configuration files, logfiles, tab backups etc.
|
||
function TAppSettings.DirnameUserAppData: String;
|
||
begin
|
||
if FDirnameUserAppData.IsEmpty then begin
|
||
if FPortableMode then
|
||
FDirnameUserAppData := GetAppDir
|
||
else begin
|
||
// GetAppConfigDir returns "/home/rick/.config/heidisql" only in a very early state.
|
||
// Later it takes the main form's caption into its folder name! Probably only before I created GetApplicationName.
|
||
FDirnameUserAppData := GetAppConfigDir(False);
|
||
FDirnameUserAppData := IncludeTrailingPathDelimiter(FDirnameUserAppData);
|
||
end;
|
||
end;
|
||
Result := FDirnameUserAppData;
|
||
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 := DirnameUserAppData;
|
||
// 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 := IncludeTrailingPathDelimiter(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
|
||
Result := DirnameUserAppData + 'Backups' + DirectorySeparator;
|
||
if not DirectoryExists(Result) then begin
|
||
ForceDirectories(Result);
|
||
end;
|
||
end;
|
||
|
||
|
||
function TAppSettings.DirnameHighlighters: string;
|
||
begin
|
||
Result := DirnameUserAppData + 'Highlighters' + DirectorySeparator;
|
||
if not DirectoryExists(Result) then begin
|
||
ForceDirectories(Result);
|
||
end;
|
||
end;
|
||
|
||
|
||
function TAppSettings.AppendDelimiter(Path: String): String;
|
||
begin
|
||
Result := Path;
|
||
if Result[Length(Result)] <> PathDelimiter then
|
||
Result := Result + PathDelimiter;
|
||
end;
|
||
|
||
{ TUTF8NoBOMEncoding }
|
||
|
||
function TUTF8NoBOMEncoding.GetPreamble: TBytes;
|
||
begin
|
||
Result := [];
|
||
SetLength(Result, 0);
|
||
end;
|
||
|
||
|
||
initialization
|
||
|
||
NumberChars := ['0'..'9', FormatSettings.DecimalSeparator, FormatSettings.ThousandSeparator];
|
||
|
||
LibHandleUser32 := LoadLibrary('User32.dll');
|
||
|
||
UTF8NoBOMEncoding := TUTF8NoBOMEncoding.Create;
|
||
|
||
DateTimeNever := MinDateTime;
|
||
|
||
// Callback used by osutil.inc:ApplicationName(), forcing a stable configuration directory. See issue #2310
|
||
OnGetApplicationName := @GetApplicationName;
|
||
|
||
end.
|
||
|
||
|