unit dbconnection; interface uses Classes, SysUtils, Windows, Generics.Collections, Generics.Defaults, DateUtils, Types, Math, Dialogs, ADODB, DB, DBCommon, ComObj, Graphics, ExtCtrls, StrUtils, AnsiStrings, Controls, Forms, System.IOUtils, System.IniFiles, SynRegExpr, gnugettext, generic_types, dbstructures, dbstructures.mysql, dbstructures.mssql, dbstructures.postgresql, dbstructures.sqlite, dbstructures.interbase, FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Error, FireDAC.UI.Intf, FireDAC.Phys.Intf, FireDAC.Stan.Def, FireDAC.Phys, FireDAC.Stan.Pool, FireDAC.Stan.Async, FireDAC.Phys.IB, FireDAC.Phys.FB, FireDAC.Phys.IBDef, FireDAC.VCLUI.Wait, FireDAC.Comp.Client, FireDAC.Stan.Param, FireDAC.DatS, FireDAC.DApt.Intf, FireDAC.DApt, FireDAC.Comp.DataSet; type {$M+} // Needed to add published properties { TDBObjectList and friends } TListNodeType = (lntNone, lntDb, lntGroup, lntTable, lntView, lntFunction, lntProcedure, lntTrigger, lntEvent, lntColumn); TListNodeTypes = Set of TListNodeType; TDBConnection = class; TConnectionParameters = class; TDBQuery = class; TDBQueryList = TObjectList; TDBObject = class; TColumnPart = (cpAll, cpName, cpType, cpAllowNull, cpDefault, cpVirtuality, cpComment, cpCollation); TColumnParts = Set of TColumnPart; TColumnDefaultType = (cdtNothing, cdtText, cdtNull, cdtAutoInc, cdtExpression); // General purpose editing status flag TEditingStatus = (esUntouched, esModified, esDeleted, esAddedUntouched, esAddedModified, esAddedDeleted); // Column object, many of them in a TObjectList TTableColumn = class(TPersistent) private FConnection: TDBConnection; FStatus: TEditingStatus; procedure SetStatus(Value: TEditingStatus); public Name, OldName: String; DataType, OldDataType: TDBDatatype; LengthSet: String; Unsigned, AllowNull, ZeroFill, LengthCustomized: Boolean; DefaultType: TColumnDefaultType; DefaultText: String; OnUpdateType: TColumnDefaultType; OnUpdateText: String; Comment, Charset, Collation, GenerationExpression, Virtuality: String; constructor Create(AOwner: TDBConnection; Serialized: String=''); destructor Destroy; override; procedure Assign(Source: TPersistent); override; function Serialize: String; function SQLCode(OverrideCollation: String=''; Parts: TColumnParts=[cpAll]): String; function ValueList: TStringList; procedure ParseDatatype(Source: String); function CastAsText: String; property Status: TEditingStatus read FStatus write SetStatus; property Connection: TDBConnection read FConnection; end; PTableColumn = ^TTableColumn; TTableColumnList = class(TObjectList) public procedure Assign(Source: TTableColumnList); end; TColumnCache = TDictionary; TTableKey = class(TPersistent) const PRIMARY = 'PRIMARY'; KEY = 'KEY'; UNIQUE = 'UNIQUE'; FULLTEXT = 'FULLTEXT'; SPATIAL = 'SPATIAL'; private FConnection: TDBConnection; function GetImageIndex: Integer; public Name, OldName: String; IndexType, OldIndexType, Algorithm, Comment: String; Columns, SubParts: TStringList; Modified, Added: Boolean; constructor Create(AOwner: TDBConnection); destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Modification(Sender: TObject); function SQLCode: String; property ImageIndex: Integer read GetImageIndex; property Connection: TDBConnection read FConnection; end; TTableKeyList = class(TObjectList) public procedure Assign(Source: TTableKeyList); end; TKeyCache = TDictionary; // Helper object to manage foreign keys in a TObjectList TForeignKey = class(TPersistent) private FConnection: TDBConnection; public KeyName, OldKeyName, Db, ReferenceDb, ReferenceTable, OnUpdate, OnDelete: String; Columns, ForeignColumns: TStringList; Modified, Added, KeyNameWasCustomized: Boolean; constructor Create(AOwner: TDBConnection); destructor Destroy; override; procedure Assign(Source: TPersistent); override; function SQLCode(IncludeSymbolName: Boolean): String; function ReferenceTableObj: TDBObject; property Connection: TDBConnection read FConnection; end; TForeignKeyList = class(TObjectList) public procedure Assign(Source: TForeignKeyList); end; TForeignKeyCache = TDictionary; TCheckConstraint = class(TPersistent) private FConnection: TDBConnection; FName, FCheckClause: String; FModified, FAdded: Boolean; public constructor Create(AOwner: TDBConnection); procedure Assign(Source: TPersistent); override; function SQLCode: String; property Connection: TDBConnection read FConnection; property Name: String read FName write FName; property CheckClause: String read FCheckClause write FCheckClause; property Modified: Boolean read FModified write FModified; property Added: Boolean read FAdded write FAdded; end; TCheckConstraintList = class(TObjectList) public procedure Assign(Source: TCheckConstraintList); end; TCheckConstraintCache = TDictionary; TRoutineParam = class(TObject) public Name, Context, Datatype: String; end; TRoutineParamList = TObjectList; TDBObject = class(TPersistent) private FCreateCode: String; FCreateCodeLoaded: Boolean; FWasSelected: Boolean; FConnection: TDBConnection; function GetObjType: String; function GetImageIndex: Integer; function GetOverlayImageIndex: Integer; function GetPath: String; function GetTableColumns: TTableColumnList; function GetTableKeys: TTableKeyList; function GetTableForeignKeys: TForeignKeyList; function GetTableCheckConstraints: TCheckConstraintList; public // Table options: Name, Schema, Database, Column, Engine, Comment, RowFormat, CreateOptions, Collation: String; Created, Updated, LastChecked: TDateTime; Rows, Size, Version, AvgRowLen, MaxDataLen, IndexLen, DataLen, DataFree, AutoInc, CheckSum: Int64; // Routine options: Body, Definer, Returns, DataAccess, Security, ArgTypes: String; Deterministic: Boolean; NodeType, GroupType: TListNodeType; constructor Create(OwnerConnection: TDBConnection); procedure Assign(Source: TPersistent); override; procedure UnloadDetails; procedure Drop; function IsSameAs(CompareTo: TDBObject): Boolean; function QuotedDatabase(AlwaysQuote: Boolean=True): String; function QuotedName(AlwaysQuote: Boolean=True; SeparateSegments: Boolean=True): String; function QuotedDbAndTableName(AlwaysQuote: Boolean=True): String; function QuotedColumn(AlwaysQuote: Boolean=True): String; function SchemaClauseIS(Prefix: String): String; function RowCount(Reload: Boolean): Int64; function GetCreateCode: String; overload; function GetCreateCode(RemoveAutoInc, RemoveDefiner: Boolean): String; overload; property ObjType: String read GetObjType; property ImageIndex: Integer read GetImageIndex; property OverlayImageIndex: Integer read GetOverlayImageIndex; property Path: String read GetPath; property CreateCode: String read GetCreateCode; property WasSelected: Boolean read FWasSelected write FWasSelected; property Connection: TDBConnection read FConnection; property TableColumns: TTableColumnList read GetTableColumns; property TableKeys: TTableKeyList read GetTableKeys; property TableForeignKeys: TForeignKeyList read GetTableForeignKeys; property TableCheckConstraints: TCheckConstraintList read GetTableCheckConstraints; end; PDBObject = ^TDBObject; TDBObjectList = class(TObjectList) private FDatabase: String; FDataSize: Int64; FLargestObjectSize: Int64; FLastUpdate: TDateTime; FCollation: String; FOnlyNodeType: TListNodeType; FObjectsLoaded: Boolean; public property Database: String read FDatabase; property DataSize: Int64 read FDataSize; property LargestObjectSize: Int64 read FLargestObjectSize; property LastUpdate: TDateTime read FLastUpdate; property Collation: String read FCollation; property OnlyNodeType: TListNodeType read FOnlyNodeType; end; TDatabaseCache = class(TObjectList); // A list of db object lists, used for caching TDBObjectComparer = class(TComparer) function Compare(const Left, Right: TDBObject): Integer; override; end; TDBObjectDropComparer = class(TComparer) function Compare(const Left, Right: TDBObject): Integer; override; end; TOidStringPairs = TDictionary; // Structures for in-memory changes of a TDBQuery TGridValue = class(TObject) public NewText, OldText: String; NewIsNull, OldIsNull: Boolean; NewIsFunction, OldIsFunction: Boolean; Modified: Boolean; destructor Destroy; override; end; TGridRow = class(TObjectList) public RecNo: Int64; Inserted: Boolean; end; TGridRows = class(TObjectList); // SSH related TProcessPipe = class(TObject) public ReadHandle: THandle; WriteHandle: THandle; constructor Create; destructor Destroy; override; end; TSecureShellCmd = class(TObject) private FProcessInfo: TProcessInformation; FInPipe: TProcessPipe; FOutPipe: TProcessPipe; FErrorPipe: TProcessPipe; FConnection: TDBConnection; function ReadPipe(const Pipe: TProcessPipe): String; function AsciiToAnsi(Text: AnsiString): AnsiString; function CleanEscSeq(const Buffer: String): String; procedure SendText(Text: String); public procedure Connect; constructor Create(Connection: TDBConnection); destructor Destroy; override; end; TSQLFunction = class(TPersistent) public Name, Declaration, Category, Description: String; end; TSQLFunctionList = class(TObjectList) private FOwner: TDBConnection; FCategories: TStringList; FNames: TStringList; public constructor Create(AOwner: TDBConnection; SQLFunctionsFileOrder: String); property Categories: TStringList read FCategories; property Names: TStringList read FNames; end; { TConnectionParameters and friends } TNetType = ( ntMySQL_TCPIP, ntMySQL_NamedPipe, ntMySQL_SSHtunnel, ntMSSQL_NamedPipe, ntMSSQL_TCPIP, ntMSSQL_SPX, ntMSSQL_VINES, ntMSSQL_RPC, ntPgSQL_TCPIP, ntPgSQL_SSHtunnel, ntSQLite, ntMySQL_ProxySQLAdmin, ntInterbase_TCPIP, ntInterbase_Local, ntFirebird_TCPIP, ntFirebird_Local ); TNetTypeGroup = (ngMySQL, ngMSSQL, ngPgSQL, ngSQLite, ngInterbase); TNetGroupLibs = TDictionary; TConnectionParameters = class(TObject) strict private FNetType: TNetType; FHostname, FUsername, FPassword, FAllDatabases, FLibraryOrProvider, FComment, FStartupScriptFilename, FSessionPath, FSSLPrivateKey, FSSLCertificate, FSSLCACertificate, FSSLCipher, FServerVersion, FSSHHost, FSSHUser, FSSHPassword, FSSHExe, FSSHPrivateKey, FIgnoreDatabasePattern: String; FPort, FSSHPort, FSSHLocalPort, FSSHTimeout, FCounter, FQueryTimeout, FKeepAlive: Integer; FLoginPrompt, FCompressed, FLocalTimeZone, FFullTableStatus, FWindowsAuth, FWantSSL, FIsFolder, FCleartextPluginEnabled: Boolean; FSessionColor: TColor; FLastConnect: TDateTime; FLogFileDdl: Boolean; FLogFileDml: Boolean; FLogFilePath: String; class var FLibraries: TNetGroupLibs; function GetImageIndex: Integer; function GetSessionName: String; public constructor Create; overload; constructor Create(SessionRegPath: String); overload; procedure SaveToRegistry; function CreateConnection(AOwner: TComponent): TDBConnection; function CreateQuery(Connection: TDbConnection): TDBQuery; function NetTypeName(LongFormat: Boolean): String; function GetNetTypeGroup: TNetTypeGroup; function IsAnyMySQL: Boolean; function IsAnyMSSQL: Boolean; function IsAnyPostgreSQL: Boolean; function IsAnySQLite: Boolean; function IsAnyInterbase: Boolean; function IsMariaDB: Boolean; function IsMySQL(StrictDetect: Boolean): Boolean; function IsPercona: Boolean; function IsTokudb: Boolean; function IsInfiniDB: Boolean; function IsInfobright: Boolean; function IsProxySQLAdmin: Boolean; function IsAzure: Boolean; function IsMemSQL: Boolean; function IsRedshift: Boolean; function IsInterbase: Boolean; function IsFirebird: Boolean; property ImageIndex: Integer read GetImageIndex; function GetLibraries: TStringList; function DefaultLibrary: String; function DefaultHost: String; function DefaultPort: Integer; function DefaultUsername: String; function DefaultIgnoreDatabasePattern: String; function GetExternalCliArguments(Connection: TDBConnection; ReplacePassword: TThreeStateBoolean): String; published property IsFolder: Boolean read FIsFolder write FIsFolder; property NetType: TNetType read FNetType write FNetType; property NetTypeGroup: TNetTypeGroup read GetNetTypeGroup; property ServerVersion: String read FServerVersion write FServerVersion; property Counter: Integer read FCounter write FCounter; property LastConnect: TDateTime read FLastConnect; property SessionPath: String read FSessionPath write FSessionPath; property SessionName: String read GetSessionName; property SessionColor: TColor read FSessionColor write FSessionColor; property Hostname: String read FHostname write FHostname; property Port: Integer read FPort write FPort; property Username: String read FUsername write FUsername; property Password: String read FPassword write FPassword; property LoginPrompt: Boolean read FLoginPrompt write FLoginPrompt; property WindowsAuth: Boolean read FWindowsAuth write FWindowsAuth; property CleartextPluginEnabled: Boolean read FCleartextPluginEnabled write FCleartextPluginEnabled; property AllDatabasesStr: String read FAllDatabases write FAllDatabases; property LibraryOrProvider: String read FLibraryOrProvider write FLibraryOrProvider; property Comment: String read FComment write FComment; property StartupScriptFilename: String read FStartupScriptFilename write FStartupScriptFilename; property QueryTimeout: Integer read FQueryTimeout write FQueryTimeout; property KeepAlive: Integer read FKeepAlive write FKeepAlive; property Compressed: Boolean read FCompressed write FCompressed; property LocalTimeZone: Boolean read FLocalTimeZone write FLocalTimeZone; property FullTableStatus: Boolean read FFullTableStatus write FFullTableStatus; property SSHHost: String read FSSHHost write FSSHHost; property SSHPort: Integer read FSSHPort write FSSHPort; property SSHUser: String read FSSHUser write FSSHUser; property SSHPassword: String read FSSHPassword write FSSHPassword; property SSHTimeout: Integer read FSSHTimeout write FSSHTimeout; property SSHPrivateKey: String read FSSHPrivateKey write FSSHPrivateKey; property SSHLocalPort: Integer read FSSHLocalPort write FSSHLocalPort; property SSHExe: String read FSSHExe write FSSHExe; property WantSSL: Boolean read FWantSSL write FWantSSL; property SSLPrivateKey: String read FSSLPrivateKey write FSSLPrivateKey; property SSLCertificate: String read FSSLCertificate write FSSLCertificate; property SSLCACertificate: String read FSSLCACertificate write FSSLCACertificate; property SSLCipher: String read FSSLCipher write FSSLCipher; property IgnoreDatabasePattern: String read FIgnoreDatabasePattern write FIgnoreDatabasePattern; property LogFileDdl: Boolean read FLogFileDdl write FLogFileDdl; property LogFileDml: Boolean read FLogFileDml write FLogFileDml; property LogFilePath: String read FLogFilePath write FLogFilePath; end; PConnectionParameters = ^TConnectionParameters; { TDBConnection } TDBLogCategory = (lcInfo, lcSQL, lcUserFiredSQL, lcError, lcDebug, lcScript); TDBLogItem = class(TObject) public Category: TDBLogCategory; LineText: String; Connection: TDBConnection; end; TDBLogItems = TObjectList; TDBLogEvent = procedure(Msg: String; Category: TDBLogCategory=lcInfo; Connection: TDBConnection=nil) of object; TDBEvent = procedure(Connection: TDBConnection; Database: String) of object; TDBDataTypeArray = Array of TDBDataType; TSQLSpecifityId = (spDatabaseTable, spDatabaseTableId, spDatabaseDrop, spDbObjectsTable, spDbObjectsCreateCol, spDbObjectsUpdateCol, spDbObjectsTypeCol, spEmptyTable, spRenameTable, spRenameView, spCurrentUserHost, spLikeCompare, spAddColumn, spChangeColumn, spRenameColumn, spGlobalStatus, spCommandsCounters, spSessionVariables, spGlobalVariables, spISSchemaCol, spUSEQuery, spKillQuery, spKillProcess, spFuncLength, spFuncCeil, spFuncLeft, spFuncNow, spLockedTables, spDisableForeignKeyChecks, spEnableForeignKeyChecks); TDBConnection = class(TComponent) private FActive: Boolean; FConnectionStarted: Cardinal; FServerUptime: Integer; FServerDateTimeOnStartup: String; FParameters: TConnectionParameters; FSecureShellCmd: TSecureShellCmd; FLoginPromptDone: Boolean; FDatabase: String; FAllDatabases: TStringList; FLogPrefix: String; FOnLog: TDBLogEvent; FOnConnected: TDBEvent; FOnDatabaseChanged: TDBEvent; FOnObjectnamesChanged: TDBEvent; FRowsFound: Int64; FRowsAffected: Int64; FWarningCount: Cardinal; FServerOS: String; FServerVersionUntouched: String; FRealHostname: String; FLastQueryDuration, FLastQueryNetworkDuration: Cardinal; FLastQuerySQL: String; FIsUnicode: Boolean; FIsSSL: Boolean; FTableEngines: TStringList; FTableEngineDefault: String; FCollationTable: TDBQuery; FCharsetTable: TDBQuery; FSessionVariables: TDBQuery; FInformationSchemaObjects: TStringList; FDatabaseCache: TDatabaseCache; FColumnCache: TColumnCache; FKeyCache: TKeyCache; FForeignKeyCache: TForeignKeyCache; FCheckConstraintCache: TCheckConstraintCache; FCurrentUserHostCombination: String; FAllUserHostCombinations: TStringList; FLockedByThread: TThread; FStringQuoteChar: Char; FQuoteChar: Char; FQuoteChars: String; FDatatypes: TDBDataTypeArray; FThreadID: Int64; FSQLSpecifities: Array[TSQLSpecifityId] of String; FKeepAliveTimer: TTimer; FFavorites: TStringList; FPrefetchResults: TDBQueryList; FForeignKeyQueriesFailed: Boolean; FInfSch: String; FIdentCharsNoQuote: TSysCharSet; FMaxRowsPerInsert: Int64; FCaseSensitivity: Integer; FSQLFunctions: TSQLFunctionList; procedure SetActive(Value: Boolean); virtual; abstract; procedure DoBeforeConnect; virtual; procedure DoAfterConnect; virtual; procedure DetectUSEQuery(SQL: String); virtual; procedure SetDatabase(Value: String); function GetThreadId: Int64; virtual; abstract; function GetCharacterSet: String; virtual; procedure SetCharacterSet(CharsetName: String); virtual; function GetLastErrorCode: Cardinal; virtual; abstract; function GetLastErrorMsg: String; virtual; abstract; function GetAllDatabases: TStringList; virtual; procedure ApplyIgnoreDatabasePattern(Dbs: TStringList); function GetTableEngines: TStringList; virtual; function GetCollationTable: TDBQuery; virtual; function GetCollationList: TStringList; virtual; function GetCharsetTable: TDBQuery; virtual; function GetCharsetList: TStringList; function GetConnectionUptime: Integer; function GetServerUptime: Integer; function GetServerNow: TDateTime; function GetCurrentUserHostCombination: String; function GetAllUserHostCombinations: TStringList; function DecodeAPIString(a: AnsiString): String; function GetRowCount(Obj: TDBObject): Int64; virtual; abstract; procedure ClearCache(IncludeDBObjects: Boolean); procedure FetchDbObjects(db: String; var Cache: TDBObjectList); virtual; abstract; procedure SetLockedByThread(Value: TThread); virtual; procedure KeepAliveTimerEvent(Sender: TObject); procedure Drop(Obj: TDBObject); virtual; procedure PrefetchResults(SQL: String); procedure FreeResults(Results: TDBQuery); function IsTextDefault(Value: String; Tp: TDBDatatype): Boolean; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); virtual; abstract; procedure Log(Category: TDBLogCategory; Msg: String); function EscapeString(Text: String; ProcessJokerChars: Boolean=False; DoQuote: Boolean=True): String; overload; function EscapeString(Text: String; Datatype: TDBDatatype): String; overload; function QuoteIdent(Identifier: String; AlwaysQuote: Boolean=True; Glue: Char=#0): String; function DeQuoteIdent(Identifier: String; Glue: Char=#0): String; function QuotedDbAndTableName(DB, Obj: String): String; function FindObject(DB, Obj: String): TDBObject; function escChars(const Text: String; EscChar, Char1, Char2, Char3, Char4: Char): String; function UnescapeString(Text: String): String; function ExtractLiteral(var SQL: String; Prefix: String): String; function GetResults(SQL: String): TDBQuery; function GetCol(SQL: String; Column: Integer=0): TStringList; function GetVar(SQL: String; Column: Integer=0): String; overload; function GetVar(SQL: String; Column: String): String; overload; function Ping(Reconnect: Boolean): Boolean; virtual; abstract; function RefreshAllDatabases: TStringList; function GetDBObjects(db: String; Refresh: Boolean=False; OnlyNodeType: TListNodeType=lntNone): TDBObjectList; function DbObjectsCached(db: String): Boolean; function ParseDateTime(Str: String): TDateTime; function GetKeyColumns(Columns: TTableColumnList; Keys: TTableKeyList): TStringList; function ConnectionInfo: TStringList; virtual; function GetLastResults: TDBQueryList; virtual; function GetCreateCode(Obj: TDBObject): String; virtual; procedure PrefetchCreateCode(Objects: TDBObjectList); function GetSessionVariables(Refresh: Boolean): TDBQuery; function GetSessionVariable(VarName: String; DefaultValue: String=''; Refresh: Boolean=False): String; function MaxAllowedPacket: Int64; virtual; function GetSQLSpecifity(Specifity: TSQLSpecifityId): String; overload; function GetSQLSpecifity(Specifity: TSQLSpecifityId; const Args: array of const): String; overload; function ExplainAnalyzer(SQL, DatabaseName: String): Boolean; virtual; function GetDateTimeValue(Input: String; Datatype: TDBDatatypeIndex): String; procedure ClearDbObjects(db: String); procedure ClearAllDbObjects; procedure ParseViewStructure(CreateCode: String; DBObj: TDBObject; var Algorithm, Definer, SQLSecurity, CheckOption, SelectCode: String); procedure ParseRoutineStructure(Obj: TDBObject; Parameters: TRoutineParamList); procedure PurgePrefetchResults; function GetDatatypeByName(var DataType: String; DeleteFromSource: Boolean; Identifier: String=''): TDBDatatype; function GetDatatypeByNativeType(NativeType: Integer; Identifier: String=''): TDBDatatype; function ApplyLimitClause(QueryType, QueryBody: String; Limit, Offset: Int64): String; function LikeClauseTail: String; property Parameters: TConnectionParameters read FParameters write FParameters; property ThreadId: Int64 read GetThreadId; property ConnectionUptime: Integer read GetConnectionUptime; property ServerUptime: Integer read GetServerUptime; property ServerNow: TDateTime read GetServerNow; property CharacterSet: String read GetCharacterSet write SetCharacterSet; property LastErrorCode: Cardinal read GetLastErrorCode; property LastErrorMsg: String read GetLastErrorMsg; property ServerOS: String read FServerOS; property ServerVersionUntouched: String read FServerVersionUntouched; property ColumnCache: TColumnCache read FColumnCache; property KeyCache: TKeyCache read FKeyCache; property ForeignKeyCache: TForeignKeyCache read FForeignKeyCache; property CheckConstraintCache: TCheckConstraintCache read FCheckConstraintCache; property QuoteChar: Char read FQuoteChar; property QuoteChars: String read FQuoteChars; function ServerVersionStr: String; function ServerVersionInt: Integer; function NdbClusterVersionInt: Integer; property RowsFound: Int64 read FRowsFound; property RowsAffected: Int64 read FRowsAffected; property WarningCount: Cardinal read FWarningCount; property LastQueryDuration: Cardinal read FLastQueryDuration; property LastQueryNetworkDuration: Cardinal read FLastQueryNetworkDuration; property IsUnicode: Boolean read FIsUnicode; property IsSSL: Boolean read FIsSSL; property AllDatabases: TStringList read GetAllDatabases; property TableEngines: TStringList read GetTableEngines; property TableEngineDefault: String read FTableEngineDefault; property CollationTable: TDBQuery read GetCollationTable; property CollationList: TStringList read GetCollationList; property CharsetTable: TDBQuery read GetCharsetTable; property CharsetList: TStringList read GetCharsetList; property InformationSchemaObjects: TStringList read FInformationSchemaObjects; function ResultCount: Integer; property CurrentUserHostCombination: String read GetCurrentUserHostCombination; property AllUserHostCombinations: TStringList read GetAllUserHostCombinations; property LockedByThread: TThread read FLockedByThread write SetLockedByThread; property Datatypes: TDBDataTypeArray read FDatatypes; property Favorites: TStringList read FFavorites; property InfSch: String read FInfSch; function GetLockedTableCount(db: String): Integer; function IdentifierEquals(Ident1, Ident2: String): Boolean; function GetTableColumns(Table: TDBObject): TTableColumnList; virtual; function GetTableKeys(Table: TDBObject): TTableKeyList; virtual; function GetTableForeignKeys(Table: TDBObject): TForeignKeyList; virtual; function GetTableCheckConstraints(Table: TDBObject): TCheckConstraintList; virtual; property MaxRowsPerInsert: Int64 read FMaxRowsPerInsert; property SQLFunctions: TSQLFunctionList read FSQLFunctions; function IsHex(Text: String): Boolean; published property Active: Boolean read FActive write SetActive default False; property Database: String read FDatabase write SetDatabase; property LogPrefix: String read FLogPrefix write FLogPrefix; property OnLog: TDBLogEvent read FOnLog write FOnLog; property OnConnected: TDBEvent read FOnConnected write FOnConnected; property OnDatabaseChanged: TDBEvent read FOnDatabaseChanged write FOnDatabaseChanged; property OnObjectnamesChanged: TDBEvent read FOnObjectnamesChanged write FOnObjectnamesChanged; end; TDBConnectionList = TObjectList; { TMySQLConnection } TMySQLRawResults = Array of PMYSQL_RES; TMySQLConnection = class(TDBConnection) private FHandle: PMYSQL; FLib: TMySQLLib; FLastRawResults: TMySQLRawResults; FStatementNum: Cardinal; procedure SetActive(Value: Boolean); override; procedure DoBeforeConnect; override; procedure DoAfterConnect; override; function GetThreadId: Int64; override; function GetCharacterSet: String; override; procedure SetCharacterSet(CharsetName: String); override; function GetLastErrorCode: Cardinal; override; function GetLastErrorMsg: String; override; function GetAllDatabases: TStringList; override; function GetTableEngines: TStringList; override; function GetCollationTable: TDBQuery; override; function GetCharsetTable: TDBQuery; override; function GetCreateViewCode(Database, Name: String): String; function GetRowCount(Obj: TDBObject): Int64; override; procedure FetchDbObjects(db: String; var Cache: TDBObjectList); override; procedure SetLockedByThread(Value: TThread); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Lib: TMySQLLib read FLib; procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); override; function Ping(Reconnect: Boolean): Boolean; override; function ConnectionInfo: TStringList; override; function GetCreateCode(Obj: TDBObject): String; override; property LastRawResults: TMySQLRawResults read FLastRawResults; function MaxAllowedPacket: Int64; override; function ExplainAnalyzer(SQL, DatabaseName: String): Boolean; override; function GetTableColumns(Table: TDBObject): TTableColumnList; override; function GetTableKeys(Table: TDBObject): TTableKeyList; override; end; TAdoRawResults = Array of _RecordSet; TAdoDBConnection = class(TDBConnection) private FAdoHandle: TAdoConnection; FLastRawResults: TAdoRawResults; FLastError: String; procedure SetActive(Value: Boolean); override; procedure DoAfterConnect; override; function GetThreadId: Int64; override; function GetLastErrorCode: Cardinal; override; function GetLastErrorMsg: String; override; function GetAllDatabases: TStringList; override; function GetCollationTable: TDBQuery; override; function GetCharsetTable: TDBQuery; override; function GetRowCount(Obj: TDBObject): Int64; override; procedure FetchDbObjects(db: String; var Cache: TDBObjectList); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); override; function Ping(Reconnect: Boolean): Boolean; override; function ConnectionInfo: TStringList; override; function GetLastResults: TDBQueryList; override; property LastRawResults: TAdoRawResults read FLastRawResults; function GetTableColumns(Table: TDBObject): TTableColumnList; override; function GetTableForeignKeys(Table: TDBObject): TForeignKeyList; override; end; TPGRawResults = Array of PPGresult; TPQerrorfields = (PG_DIAG_SEVERITY, PG_DIAG_SQLSTATE, PG_DIAG_MESSAGE_PRIMARY, PG_DIAG_MESSAGE_DETAIL, PG_DIAG_MESSAGE_HINT, PG_DIAG_STATEMENT_POSITION, PG_DIAG_INTERNAL_POSITION, PG_DIAG_INTERNAL_QUERY, PG_DIAG_CONTEXT, PG_DIAG_SOURCE_FILE, PG_DIAG_SOURCE_LINE, PG_DIAG_SOURCE_FUNCTION); TPgConnection = class(TDBConnection) private FHandle: PPGconn; FLib: TPostgreSQLLib; FLastRawResults: TPGRawResults; FRegClasses: TOidStringPairs; procedure SetActive(Value: Boolean); override; procedure DoBeforeConnect; override; procedure DoAfterConnect; override; function GetThreadId: Int64; override; procedure SetCharacterSet(CharsetName: String); override; function GetLastErrorCode: Cardinal; override; function GetLastErrorMsg: String; override; function GetAllDatabases: TStringList; override; function GetCharsetTable: TDBQuery; override; procedure FetchDbObjects(db: String; var Cache: TDBObjectList); override; procedure Drop(Obj: TDBObject); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Lib: TPostgreSQLLib read FLib; procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); override; function Ping(Reconnect: Boolean): Boolean; override; function ConnectionInfo: TStringList; override; function GetRowCount(Obj: TDBObject): Int64; override; property LastRawResults: TPGRawResults read FLastRawResults; property RegClasses: TOidStringPairs read FRegClasses; function GetTableColumns(Table: TDBObject): TTableColumnList; override; function GetTableKeys(Table: TDBObject): TTableKeyList; override; function GetTableForeignKeys(Table: TDBObject): TForeignKeyList; override; end; TSQLiteConnection = class; TSQLiteGridRows = class(TGridRows) private FConnection: TSQLiteConnection; public Statement: Psqlite3_stmt; // Used for querying result structures constructor Create(AOwner: TSQLiteConnection); destructor Destroy; override; end; TSQLiteRawResults = Array of TSQLiteGridRows; TSQLiteConnection = class(TDBConnection) private FHandle: Psqlite3; FLib: TSQLiteLib; FLastRawResults: TSQLiteRawResults; FMainDbName: UTF8String; procedure SetActive(Value: Boolean); override; procedure DoBeforeConnect; override; function GetThreadId: Int64; override; function GetLastErrorCode: Cardinal; override; function GetLastErrorMsg: String; override; function GetAllDatabases: TStringList; override; function GetCollationList: TStringList; override; function GetCharsetTable: TDBQuery; override; procedure FetchDbObjects(db: String; var Cache: TDBObjectList); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Lib: TSQLiteLib read FLib; procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); override; function Ping(Reconnect: Boolean): Boolean; override; function GetCreateCode(Obj: TDBObject): String; override; function GetRowCount(Obj: TDBObject): Int64; override; property LastRawResults: TSQLiteRawResults read FLastRawResults; function GetTableColumns(Table: TDBObject): TTableColumnList; override; function GetTableKeys(Table: TDBObject): TTableKeyList; override; function GetTableForeignKeys(Table: TDBObject): TForeignKeyList; override; end; TInterbaseRawResults = Array of TFDQuery; TIbDrivers = TDictionary; TFbDrivers = TDictionary; TInterbaseConnection = class(TDBConnection) private FFDHandle: TFDConnection; FLastError: String; FLastErrorCode: Integer; FLastRawResults: TInterbaseRawResults; class var FIbDrivers: TIbDrivers; class var FFbDrivers: TFbDrivers; procedure SetActive(Value: Boolean); override; procedure DoBeforeConnect; override; function GetThreadId: Int64; override; procedure OnFdError(ASender: TObject; AInitiator: TObject; var AException: Exception); function GetLastErrorCode: Cardinal; override; function GetLastErrorMsg: String; override; function GetAllDatabases: TStringList; override; function GetCollationTable: TDBQuery; override; function GetCharsetTable: TDBQuery; override; procedure FetchDbObjects(db: String; var Cache: TDBObjectList); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); override; function Ping(Reconnect: Boolean): Boolean; override; function GetCreateCode(Obj: TDBObject): String; override; function GetRowCount(Obj: TDBObject): Int64; override; property LastRawResults: TInterbaseRawResults read FLastRawResults; function GetTableColumns(Table: TDBObject): TTableColumnList; override; function GetTableKeys(Table: TDBObject): TTableKeyList; override; function GetTableForeignKeys(Table: TDBObject): TForeignKeyList; override; end; { TDBQuery } TDBQuery = class(TComponent) private FSQL: String; FConnection: TDBConnection; FRecNo, FRecordCount: Int64; FColumnNames: TStringList; FColumnOrgNames: TStringList; FAutoIncrementColumn: Integer; FColumnTypes: Array of TDBDatatype; FColumnLengths: TIntegerDynArray; FColumnFlags: TCardinalDynArray; FCurrentUpdateRow: TGridRow; FEof: Boolean; FStoreResult: Boolean; FColumns: TTableColumnList; FKeys: TTableKeyList; FForeignKeys: TForeignKeyList; FEditingPrepared: Boolean; FUpdateData: TGridRows; FDBObject: TDBObject; FFormatSettings: TFormatSettings; procedure SetRecNo(Value: Int64); virtual; abstract; function ColumnExists(Column: Integer): Boolean; procedure SetColumnOrgNames(Value: TStringList); procedure SetDBObject(Value: TDBObject); procedure CreateUpdateRow; function GetKeyColumns: TStringList; function GridQuery(QueryType, QueryBody: String): String; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); virtual; abstract; procedure First; procedure Next; function ColumnCount: Integer; function GetColBinData(Column: Integer; var baData: TBytes): Boolean; virtual; function Col(Column: Integer; IgnoreErrors: Boolean=False): String; overload; virtual; abstract; function Col(ColumnName: String; IgnoreErrors: Boolean=False): String; overload; function ColumnLengths(Column: Integer): Int64; virtual; function HexValue(Column: Integer; IgnoreErrors: Boolean=False): String; overload; function HexValue(BinValue: String): String; overload; function HexValue(var ByteData: TBytes): String; overload; function DataType(Column: Integer): TDBDataType; function MaxLength(Column: Integer): Int64; function ValueList(Column: Integer): TStringList; // Todo: overload ColumnExists: function ColExists(Column: String): Boolean; function ColIsPrimaryKeyPart(Column: Integer): Boolean; virtual; abstract; function ColIsUniqueKeyPart(Column: Integer): Boolean; virtual; abstract; function ColIsKeyPart(Column: Integer): Boolean; virtual; abstract; function ColIsVirtual(Column: Integer): Boolean; function ColAttributes(Column: Integer): TTableColumn; function IsNull(Column: Integer): Boolean; overload; virtual; abstract; function IsNull(Column: String): Boolean; overload; function IsFunction(Column: Integer): Boolean; function HasResult: Boolean; virtual; abstract; function GetWhereClause: String; procedure CheckEditable; function IsEditable: Boolean; procedure DeleteRow; function InsertRow: Int64; procedure SetCol(Column: Integer; NewText: String; Null: Boolean; IsFunction: Boolean); function EnsureFullRow(Refresh: Boolean): Boolean; function HasFullData: Boolean; function Modified(Column: Integer): Boolean; overload; function Modified: Boolean; overload; function Inserted: Boolean; function SaveModifications: Boolean; function DatabaseName: String; virtual; abstract; function TableName: String; overload; function TableName(Column: Integer): String; overload; virtual; abstract; function QuotedDbAndTableName: String; procedure DiscardModifications; procedure PrepareColumnAttributes; procedure PrepareEditing; property RecNo: Int64 read FRecNo write SetRecNo; property Eof: Boolean read FEof; property RecordCount: Int64 read FRecordCount; property ColumnNames: TStringList read FColumnNames; property StoreResult: Boolean read FStoreResult write FStoreResult; property ColumnOrgNames: TStringList read FColumnOrgNames write SetColumnOrgNames; property AutoIncrementColumn: Integer read FAutoIncrementColumn; property DBObject: TDBObject read FDBObject write SetDBObject; property SQL: String read FSQL write FSQL; property Connection: TDBConnection read FConnection; end; PDBQuery = ^TDBQuery; { TMySQLQuery } TMySQLQuery = class(TDBQuery) private FConnection: TMySQLConnection; FResultList: TMySQLRawResults; FCurrentResults: PMYSQL_RES; FCurrentRow: PMYSQL_ROW; procedure SetRecNo(Value: Int64); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); override; function GetColBinData(Column: Integer; var baData: TBytes): Boolean; override; function Col(Column: Integer; IgnoreErrors: Boolean=False): String; overload; override; function ColIsPrimaryKeyPart(Column: Integer): Boolean; override; function ColIsUniqueKeyPart(Column: Integer): Boolean; override; function ColIsKeyPart(Column: Integer): Boolean; override; function IsNull(Column: Integer): Boolean; overload; override; function HasResult: Boolean; override; function DatabaseName: String; override; function TableName(Column: Integer): String; overload; override; end; TAdoDBQuery = class(TDBQuery) private FCurrentResults: TAdoQuery; FResultList: Array of TAdoQuery; procedure SetRecNo(Value: Int64); override; public destructor Destroy; override; procedure Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); override; function Col(Column: Integer; IgnoreErrors: Boolean=False): String; overload; override; function ColIsPrimaryKeyPart(Column: Integer): Boolean; override; function ColIsUniqueKeyPart(Column: Integer): Boolean; override; function ColIsKeyPart(Column: Integer): Boolean; override; function IsNull(Column: Integer): Boolean; overload; override; function HasResult: Boolean; override; function DatabaseName: String; override; function TableName(Column: Integer): String; overload; override; end; TPGQuery = class(TDBQuery) private FConnection: TPgConnection; FCurrentResults: PPGresult; FRecNoLocal: Integer; FResultList: TPGRawResults; procedure SetRecNo(Value: Int64); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); override; function Col(Column: Integer; IgnoreErrors: Boolean=False): String; overload; override; function ColIsPrimaryKeyPart(Column: Integer): Boolean; override; function ColIsUniqueKeyPart(Column: Integer): Boolean; override; function ColIsKeyPart(Column: Integer): Boolean; override; function IsNull(Column: Integer): Boolean; overload; override; function HasResult: Boolean; override; function DatabaseName: String; override; function TableName(Column: Integer): String; overload; override; end; TSQLiteQuery = class(TDBQuery) private FConnection: TSQLiteConnection; FCurrentResults: TSQLiteGridRows; FRecNoLocal: Integer; FResultList: TSQLiteRawResults; procedure SetRecNo(Value: Int64); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); override; function Col(Column: Integer; IgnoreErrors: Boolean=False): String; overload; override; function ColIsPrimaryKeyPart(Column: Integer): Boolean; override; function ColIsUniqueKeyPart(Column: Integer): Boolean; override; function ColIsKeyPart(Column: Integer): Boolean; override; function IsNull(Column: Integer): Boolean; overload; override; function HasResult: Boolean; override; function DatabaseName: String; override; function TableName(Column: Integer): String; overload; override; end; TInterbaseQuery = class(TDBQuery) private FConnection: TInterbaseConnection; FCurrentResults: TFDDataSet; FRecNoLocal: Integer; FResultList: TInterbaseRawResults; procedure SetRecNo(Value: Int64); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); override; function Col(Column: Integer; IgnoreErrors: Boolean=False): String; overload; override; function ColIsPrimaryKeyPart(Column: Integer): Boolean; override; function ColIsUniqueKeyPart(Column: Integer): Boolean; override; function ColIsKeyPart(Column: Integer): Boolean; override; function IsNull(Column: Integer): Boolean; overload; override; function HasResult: Boolean; override; function DatabaseName: String; override; function TableName(Column: Integer): String; overload; override; end; procedure SQLite_CollationNeededCallback(userData:Pointer; ppDb:Psqlite3; eTextRep:integer; zName:PAnsiChar); cdecl; function SQLite_Collation(userData: Pointer; lenA: Integer; strA: PAnsiChar; lenB: Integer; strB: PAnsiChar): Integer; cdecl; function mysql_authentication_dialog_ask( Handle: PMYSQL; _type: Integer; prompt: PAnsiChar; buf: PAnsiChar; buf_len: Integer ): PAnsiChar; cdecl; exports mysql_authentication_dialog_ask; {$I const.inc} implementation uses apphelpers, loginform, change_password; { TProcessPipe } constructor TProcessPipe.Create; var Success: Boolean; begin inherited; Success := CreatePipe(ReadHandle, WriteHandle, nil, 8192); if Success then Success := DuplicateHandle( GetCurrentProcess, ReadHandle, GetCurrentProcess, @ReadHandle, 0, True, DUPLICATE_CLOSE_SOURCE OR DUPLICATE_SAME_ACCESS ); if Success then Success := DuplicateHandle( GetCurrentProcess, WriteHandle, GetCurrentProcess, @WriteHandle, 0, True, DUPLICATE_CLOSE_SOURCE OR DUPLICATE_SAME_ACCESS ); if not Success then raise EDbError.Create(_('Error creating I/O pipes')); end; destructor TProcessPipe.Destroy; begin CloseHandle(ReadHandle); CloseHandle(WriteHandle); inherited; end; { TSecureShellCmd } constructor TSecureShellCmd.Create(Connection: TDBConnection); begin inherited Create; FConnection := Connection; FInPipe := TProcessPipe.Create; FOutPipe := TProcessPipe.Create; FErrorPipe := TProcessPipe.Create; end; destructor TSecureShellCmd.Destroy; begin FConnection.Log(lcInfo, f_('Closing SSH process #%d ...', [FProcessInfo.dwProcessId])); TerminateProcess(FProcessInfo.hProcess, 0); CloseHandle(FProcessInfo.hProcess); CloseHandle(FProcessInfo.hThread); FInPipe.Free; FOutPipe.Free; FErrorPipe.Free; inherited; end; procedure TSecureShellCmd.Connect; var SshCmd, SshCmdDisplay, DialogTitle: String; OutText, ErrorText, UserInput: String; rx: TRegExpr; StartupInfo: TStartupInfo; ExitCode: LongWord; Waited, PortChecks: Integer; IsPlink: Boolean; begin // Check if local port is open PortChecks := 0; while not PortOpen(FConnection.Parameters.SSHLocalPort) do begin Inc(PortChecks); if PortChecks >= 20 then raise EDbError.CreateFmt(_('Could not execute SSH command: Port %d already in use.'), [FConnection.Parameters.SSHLocalPort]); FConnection.Log(lcInfo, f_('Port #%d in use. Checking if #%d is available...', [FConnection.Parameters.SSHLocalPort, FConnection.Parameters.SSHLocalPort+1])); FConnection.Parameters.SSHLocalPort := FConnection.Parameters.SSHLocalPort + 1; end; // Build SSH command line // plink bob@domain.com -pw myPassw0rd1 -P 22 -i "keyfile.pem" -L 55555:localhost:3306 IsPlink := ExecRegExprI('([pk]link|putty)', FConnection.Parameters.SSHExe); SshCmd := FConnection.Parameters.SSHExe; if IsPlink then SshCmd := SshCmd + ' -ssh'; SshCmd := SshCmd + ' '; if FConnection.Parameters.SSHUser.Trim <> '' then SshCmd := SshCmd + FConnection.Parameters.SSHUser.Trim + '@'; if FConnection.Parameters.SSHHost.Trim <> '' then SshCmd := SshCmd + FConnection.Parameters.SSHHost.Trim else SshCmd := SshCmd + FConnection.Parameters.Hostname; if FConnection.Parameters.SSHPassword <> '' then begin // Escape double quote with backslash, see issue #261 SshCmd := SshCmd + ' -pw "' + StringReplace(FConnection.Parameters.SSHPassword, '"', '\"', [rfReplaceAll]) + '"'; end; if FConnection.Parameters.SSHPort > 0 then SshCmd := SshCmd + IfThen(IsPlink, ' -P ', ' -p ') + IntToStr(FConnection.Parameters.SSHPort); if FConnection.Parameters.SSHPrivateKey <> '' then SshCmd := SshCmd + ' -i "' + FConnection.Parameters.SSHPrivateKey + '"'; SshCmd := SshCmd + ' -N -L ' + IntToStr(FConnection.Parameters.SSHLocalPort) + ':' + FConnection.Parameters.Hostname + ':' + IntToStr(FConnection.Parameters.Port); rx := TRegExpr.Create; rx.Expression := '(-pw\s+")[^"]*(")'; SshCmdDisplay := rx.Replace(SshCmd, '${1}******${2}', True); FConnection.Log(lcInfo, f_('Attempt to create SSH process, waiting %ds for response ...', [FConnection.Parameters.SSHTimeout])); FConnection.Log(lcInfo, SshCmdDisplay); // Prepare process FillChar(StartupInfo, SizeOf(StartupInfo), 0); StartupInfo.cb := SizeOf(StartupInfo); StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES; StartupInfo.wShowWindow := SW_HIDE; StartupInfo.hStdInput:= FInPipe.ReadHandle; StartupInfo.hStdError:= FErrorPipe.WriteHandle; StartupInfo.hStdOutput:= FOutPipe.WriteHandle; // Create plink.exe process FillChar(FProcessInfo, SizeOf(FProcessInfo), 0); if not CreateProcess( nil, PChar(SshCmd), nil, nil, true, CREATE_DEFAULT_ERROR_MODE or CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, PChar(GetCurrentDir), StartupInfo, FProcessInfo) then begin ErrorText := CRLF + CRLF + SshCmdDisplay + CRLF + CRLF + 'System message: ' + SysErrorMessage(GetLastError); ErrorText := f_('Could not execute SSH command: %s', [ErrorText]); raise EDbError.Create(ErrorText); end; // Wait until timeout has finished. // Todo: Find a way to wait only until connection is established // Parse pipe output and probably show some message in a dialog. Waited := 0; DialogTitle := ExtractFileName(FConnection.Parameters.SSHExe); while Waited < FConnection.Parameters.SSHTimeout*1000 do begin Inc(Waited, 200); WaitForSingleObject(FProcessInfo.hProcess, 200); GetExitCodeProcess(FProcessInfo.hProcess, ExitCode); if ExitCode <> STILL_ACTIVE then raise EDbError.CreateFmt(_('SSH exited unexpected. Command line was: %s'), [CRLF+SshCmdDisplay]); OutText := Trim(ReadPipe(FOutPipe)); ErrorText := ReadPipe(FErrorPipe); if (OutText <> '') or (ErrorText <> '') then begin FConnection.Log(lcDebug, Format('SSH output after %d ms. OutPipe: "%s" ErrorPipe: "%s"', [Waited, OutText, ErrorText])); end; if OutText <> '' then begin if ExecRegExpr('login as\s*\:', OutText) then begin // Prompt for username UserInput := InputBox(DialogTitle, OutText, ''); SendText(UserInput + CRLF); end else if ExecRegExpr('(password|Passphrase for key "[^"]+")\s*\:', OutText) then begin // Prompt for sensitive input. Send * as first char of prompt param so InputBox hides input characters UserInput := InputBox(DialogTitle, #31+OutText, ''); SendText(UserInput + CRLF); end else begin // Informational message box rx.Expression := '^[^\.]+\.'; if rx.Exec(OutText) then begin // First words end with a dot - use it as caption MessageDialog(DialogTitle + ': ' + rx.Match[0], OutText, mtInformation, [mbOK]) end else begin MessageDialog(DialogTitle, OutText, mtInformation, [mbOK]); end; end; end; if ErrorText <> '' then begin rx.Expression := '([^\.]+\?)(\s*\(y\/n\s*(,[^\)]+)?\)\s*)$'; if rx.Exec(ErrorText) then begin // Prompt user with question case MessageDialog(Trim(rx.Match[1]), Copy(ErrorText, 1, Length(ErrorText)-rx.MatchLen[2]), mtConfirmation, [mbYes, mbNo, mbCancel]) of mrYes: SendText('y'); mrNo: SendText('n'); mrCancel: begin Destroy; raise EDbError.Create(_('SSH command cancelled')); end; end; end else if ErrorText.StartsWith('Using username ', True) // see issue #577 - new plink version sends this informational text to error pipe or ErrorText.StartsWith('Pre-authentication banner ', True) // see issue #704 or ErrorText.StartsWith('Access granted. Press Return to begin session', True) // see issue #1114 then begin FConnection.Log(lcError, 'SSH: '+ErrorText); SendText(CRLF); end else begin // Any other error message goes here. if ErrorText.Contains('Access denied') then begin // This is a final connection error - end loop in this case Destroy; raise EDbError.Create(ErrorText); end else begin // Just show error text and proceed looping MessageDialog(DialogTitle, ErrorText, mtError, [mbOK]); end; end; end; Application.ProcessMessages; end; rx.Free; end; function TSecureShellCmd.ReadPipe(const Pipe: TProcessPipe): String; var BufferReadCount, OutLen: Cardinal; BytesRemaining: Cardinal; Buffer: array [0..1023] of AnsiChar; R: AnsiString; begin Result := ''; if Pipe.ReadHandle = INVALID_HANDLE_VALUE then raise EDbError.Create(_('Error reading I/O pipes')); // Check if there is data to read from stdout PeekNamedPipe(Pipe.ReadHandle, nil, 0, nil, @BufferReadCount, nil); if BufferReadCount <> 0 then begin FillChar(Buffer, sizeof(Buffer), 'z'); // Read by 1024 bytes chunks BytesRemaining := BufferReadCount; OutLen := 0; while BytesRemaining >= 1024 do begin // Read stdout pipe ReadFile(Pipe.ReadHandle, Buffer, 1024, BufferReadCount, nil); Dec(BytesRemaining, BufferReadCount); SetLength(R, OutLen + BufferReadCount); Move(Buffer, R[OutLen + 1], BufferReadCount); Inc(OutLen, BufferReadCount); end; if BytesRemaining > 0 then begin ReadFile(Pipe.ReadHandle, Buffer, BytesRemaining, BufferReadCount, nil); SetLength(R, OutLen + BufferReadCount); Move(Buffer, R[OutLen + 1], BufferReadCount); end; R := AsciiToAnsi(R); {$WARNINGS OFF} Result := AnsiToUtf8(R); {$WARNINGS ON} Result := CleanEscSeq(Result); end; Result := StringReplace(Result, #13+CRLF, CRLF, [rfReplaceAll]); end; function TSecureShellCmd.AsciiToAnsi(Text: AnsiString): AnsiString; const cMaxLength = 255; var PText: PAnsiChar; begin Result := ''; PText := AnsiStrings.AnsiStrAlloc(cMaxLength); while Text <> '' do begin AnsiStrings.StrPCopy(PText, copy(Text, 1, cMaxLength-1)); OemToAnsi(PText, PText); Result := Result + AnsiStrings.StrPas(PText); Delete(Text, 1, cMaxLength-1); end; AnsiStrings.StrDispose(PText); end; function TSecureShellCmd.CleanEscSeq(const Buffer: String): String; var i: Integer; chr: Char; EscFlag, Process: Boolean; EscBuffer: String[80]; begin Result := ''; EscFlag := False; for i:=1 to Length(Buffer) do begin chr := buffer[I]; if EscFLag then begin Process := False; if (Length(EscBuffer) = 0) and CharInSet(Chr, ['D', 'M', 'E', 'H', '7', '8', '=', '>', '<']) then Process := True else if (Length(EscBuffer) = 1) and (EscBuffer[1] in ['(', ')', '*', '+']) then Process := True else if CharInSet(Chr, ['0'..'9', ';', '?', ' ']) or ((Length(EscBuffer) = 0) and CharInSet(chr, ['[', '(', ')', '*', '+'])) then begin {$WARNINGS OFF} EscBuffer := EscBuffer + Chr; {$WARNINGS ON} if Length(EscBuffer) >= High(EscBuffer) then begin MessageBeep(MB_ICONASTERISK); EscBuffer := ''; EscFlag := FALSE; end; end else Process := True; if Process then begin EscBuffer := ''; EscFlag := False; end; end else if chr = #27 then begin EscBuffer := ''; EscFlag := True; end; Result := Result + chr; end; end; procedure TSecureShellCmd.SendText(Text: String); var WrittenBytes: Cardinal; TextA: AnsiString; begin {$WARNINGS OFF} TextA := Utf8ToAnsi(Text); {$WARNINGS ON} if TextA <> '' then WriteFile(FInPipe.WriteHandle, TextA[1], Length(TextA), WrittenBytes, nil); end; { TConnectionParameters } constructor TConnectionParameters.Create; begin inherited Create; FIsFolder := False; FNetType := TNetType(AppSettings.GetDefaultInt(asNetType)); FHostname := DefaultHost; FLoginPrompt := AppSettings.GetDefaultBool(asLoginPrompt); FWindowsAuth := AppSettings.GetDefaultBool(asWindowsAuth); FCleartextPluginEnabled := AppSettings.GetDefaultBool(asCleartextPluginEnabled); FUsername := DefaultUsername; FPassword := AppSettings.GetDefaultString(asPassword); FPort := DefaultPort; FCompressed := AppSettings.GetDefaultBool(asCompressed); FAllDatabases := AppSettings.GetDefaultString(asDatabases); FLibraryOrProvider := DefaultLibrary; FComment := AppSettings.GetDefaultString(asComment); FSSHExe := AppSettings.GetDefaultString(asSshExecutable); FSSHHost := AppSettings.GetDefaultString(asSSHtunnelHost); FSSHPort := AppSettings.GetDefaultInt(asSSHtunnelHostPort); FSSHUser := AppSettings.GetDefaultString(asSSHtunnelUser); FSSHPassword := AppSettings.GetDefaultString(asSSHtunnelPassword); FSSHTimeout := AppSettings.GetDefaultInt(asSSHtunnelTimeout); FSSHPrivateKey := AppSettings.GetDefaultString(asSSHtunnelPrivateKey); FSSHLocalPort := FPort + 1; FWantSSL := AppSettings.GetDefaultBool(asSSLActive); FSSLPrivateKey := AppSettings.GetDefaultString(asSSLKey); FSSLCertificate := AppSettings.GetDefaultString(asSSLCert); FSSLCACertificate := AppSettings.GetDefaultString(asSSLCA); FSSLCipher := AppSettings.GetDefaultString(asSSLCipher); FStartupScriptFilename := AppSettings.GetDefaultString(asStartupScriptFilename); FQueryTimeout := AppSettings.GetDefaultInt(asQueryTimeout); FKeepAlive := AppSettings.GetDefaultInt(asKeepAlive); FLocalTimeZone := AppSettings.GetDefaultBool(asLocalTimeZone); FFullTableStatus := AppSettings.GetDefaultBool(asFullTableStatus); FSessionColor := AppSettings.GetDefaultInt(asTreeBackground); FIgnoreDatabasePattern := DefaultIgnoreDatabasePattern; FLogFileDdl := AppSettings.GetDefaultBool(asLogFileDdl); FLogFileDml := AppSettings.GetDefaultBool(asLogFileDml); FLogFilePath := AppSettings.GetDefaultString(asLogFilePath); FLastConnect := 0; FCounter := 0; FServerVersion := ''; end; constructor TConnectionParameters.Create(SessionRegPath: String); var DummyDate: TDateTime; begin // Parameters from stored registry key Create; if not AppSettings.SessionPathExists(SessionRegPath) then raise Exception.Create(f_('Error: Session "%s" not found in registry.', [SessionRegPath])); FSessionPath := SessionRegPath; AppSettings.SessionPath := SessionRegPath; if AppSettings.ValueExists(asSessionFolder) then begin FIsFolder := True; end else begin FSessionColor := AppSettings.ReadInt(asTreeBackground); FNetType := TNetType(AppSettings.ReadInt(asNetType)); if (FNetType > High(TNetType)) or (FNetType < Low(TNetType)) then begin ErrorDialog(f_('Unsupported "NetType" value (%d) found in settings for session "%s".', [Integer(FNetType), FSessionPath]) +CRLF+CRLF+ _('Loaded as MySQL/MariaDB session.') ); FNetType := ntMySQL_TCPIP; end; FHostname := AppSettings.ReadString(asHost); FUsername := AppSettings.ReadString(asUser); FPassword := decrypt(AppSettings.ReadString(asPassword)); FLoginPrompt := AppSettings.ReadBool(asLoginPrompt); FWindowsAuth := AppSettings.ReadBool(asWindowsAuth); FCleartextPluginEnabled := AppSettings.ReadBool(asCleartextPluginEnabled); FPort := MakeInt(AppSettings.ReadString(asPort)); FCompressed := AppSettings.ReadBool(asCompressed); FAllDatabases := AppSettings.ReadString(asDatabases); FLibraryOrProvider := AppSettings.ReadString(asLibrary, '', DefaultLibrary); FComment := AppSettings.ReadString(asComment); FSSHExe := AppSettings.ReadString(asSshExecutable); FSSHHost := AppSettings.ReadString(asSSHtunnelHost); FSSHPort := AppSettings.ReadInt(asSSHtunnelHostPort); FSSHUser := AppSettings.ReadString(asSSHtunnelUser); FSSHPassword := decrypt(AppSettings.ReadString(asSSHtunnelPassword)); FSSHTimeout := AppSettings.ReadInt(asSSHtunnelTimeout); if FSSHTimeout < 1 then FSSHTimeout := 1; FSSHPrivateKey := AppSettings.ReadString(asSSHtunnelPrivateKey); FSSHLocalPort := AppSettings.ReadInt(asSSHtunnelPort); FSSLPrivateKey := AppSettings.ReadString(asSSLKey); // Auto-activate SSL for sessions created before UseSSL was introduced: FWantSSL := AppSettings.ReadBool(asSSLActive, '', FSSLPrivateKey<>''); FSSLCertificate := AppSettings.ReadString(asSSLCert); FSSLCACertificate := AppSettings.ReadString(asSSLCA); FSSLCipher := AppSettings.ReadString(asSSLCipher); FStartupScriptFilename := AppSettings.ReadString(asStartupScriptFilename); FQueryTimeout := AppSettings.ReadInt(asQueryTimeout); FKeepAlive := AppSettings.ReadInt(asKeepAlive); FLocalTimeZone := AppSettings.ReadBool(asLocalTimeZone); FFullTableStatus := AppSettings.ReadBool(asFullTableStatus); FIgnoreDatabasePattern := AppSettings.ReadString(asIgnoreDatabasePattern); FLogFileDdl := AppSettings.ReadBool(asLogFileDdl); FLogFileDml := AppSettings.ReadBool(asLogFileDml); FLogFilePath := AppSettings.ReadString(asLogFilePath); FServerVersion := AppSettings.ReadString(asServerVersionFull); DummyDate := 0; FLastConnect := StrToDateTimeDef(AppSettings.ReadString(asLastConnect), DummyDate); FCounter := AppSettings.ReadInt(asConnectCount); AppSettings.ResetPath; if FSSHExe.IsEmpty then begin // Legacy support: was a global setting // Globals must be read without session path FSSHExe := AppSettings.ReadString(asPlinkExecutable); end; end; end; procedure TConnectionParameters.SaveToRegistry; var IsNew: Boolean; begin // Save current values to registry IsNew := not AppSettings.SessionPathExists(FSessionPath); AppSettings.SessionPath := FSessionPath; if IsNew then AppSettings.WriteString(asSessionCreated, DateTimeToStr(Now)); if FIsFolder then AppSettings.WriteBool(asSessionFolder, True) else begin AppSettings.WriteString(asHost, FHostname); AppSettings.WriteBool(asWindowsAuth, FWindowsAuth); AppSettings.WriteBool(asCleartextPluginEnabled, FCleartextPluginEnabled); AppSettings.WriteString(asUser, FUsername); AppSettings.WriteString(asPassword, encrypt(FPassword)); AppSettings.WriteBool(asLoginPrompt, FLoginPrompt); AppSettings.WriteString(asPort, IntToStr(FPort)); AppSettings.WriteInt(asNetType, Integer(FNetType)); AppSettings.WriteBool(asCompressed, FCompressed); AppSettings.WriteBool(asLocalTimeZone, FLocalTimeZone); AppSettings.WriteInt(asQueryTimeout, FQueryTimeout); AppSettings.WriteInt(asKeepAlive, FKeepAlive); AppSettings.WriteBool(asFullTableStatus, FFullTableStatus); AppSettings.WriteString(asDatabases, FAllDatabases); AppSettings.WriteString(asLibrary, FLibraryOrProvider); AppSettings.WriteString(asComment, FComment); AppSettings.WriteString(asStartupScriptFilename, FStartupScriptFilename); AppSettings.WriteInt(asTreeBackground, FSessionColor); AppSettings.WriteString(asSshExecutable, FSSHExe); AppSettings.WriteString(asSSHtunnelHost, FSSHHost); AppSettings.WriteInt(asSSHtunnelHostPort, FSSHPort); AppSettings.WriteString(asSSHtunnelUser, FSSHUser); AppSettings.WriteString(asSSHtunnelPassword, encrypt(FSSHPassword)); AppSettings.WriteInt(asSSHtunnelTimeout, FSSHTimeout); AppSettings.WriteString(asSSHtunnelPrivateKey, FSSHPrivateKey); AppSettings.WriteInt(asSSHtunnelPort, FSSHLocalPort); AppSettings.WriteBool(asSSLActive, FWantSSL); AppSettings.WriteString(asSSLKey, FSSLPrivateKey); AppSettings.WriteString(asSSLCert, FSSLCertificate); AppSettings.WriteString(asSSLCA, FSSLCACertificate); AppSettings.WriteString(asSSLCipher, FSSLCipher); AppSettings.WriteString(asIgnoreDatabasePattern, FIgnoreDatabasePattern); AppSettings.WriteBool(asLogFileDdl, FLogFileDdl); AppSettings.WriteBool(asLogFileDml, FLogFileDml); AppSettings.WriteString(asLogFilePath, FLogFilePath); AppSettings.ResetPath; end; end; function TConnectionParameters.CreateConnection(AOwner: TComponent): TDBConnection; begin case NetTypeGroup of ngMySQL: Result := TMySQLConnection.Create(AOwner); ngMSSQL: Result := TAdoDBConnection.Create(AOwner); ngPgSQL: Result := TPgConnection.Create(AOwner); ngSQLite: Result := TSQLiteConnection.Create(AOwner); ngInterbase: Result := TInterbaseConnection.Create(AOwner); else raise Exception.CreateFmt(_(MsgUnhandledNetType), [Integer(FNetType)]); end; Result.Parameters := Self; end; function TConnectionParameters.CreateQuery(Connection: TDbConnection): TDBQuery; begin case NetTypeGroup of ngMySQL: Result := TMySQLQuery.Create(Connection); ngMSSQL: Result := TAdoDBQuery.Create(Connection); ngPgSQL: Result := TPGQuery.Create(Connection); ngSQLite: Result := TSQLiteQuery.Create(Connection); ngInterbase: Result := TInterbaseQuery.Create(Connection); else raise Exception.CreateFmt(_(MsgUnhandledNetType), [Integer(FNetType)]); end; end; function TConnectionParameters.NetTypeName(LongFormat: Boolean): String; const PrefixMysql = 'MariaDB or MySQL'; PrefixProxysql = 'ProxySQL Admin'; PrefixMssql = 'Microsoft SQL Server'; PrefixPostgres = 'PostgreSQL'; PrefixRedshift = 'Redshift PG'; PrefixSqlite = 'SQLite'; PrefixInterbase = 'Interbase'; PrefixFirebird = 'Firebird'; begin // Return the name of a net type, either in short or long format Result := 'Unknown'; if LongFormat then begin case FNetType of ntMySQL_TCPIP: Result := PrefixMysql+' (TCP/IP)'; ntMySQL_NamedPipe: Result := PrefixMysql+' (named pipe)'; ntMySQL_SSHtunnel: Result := PrefixMysql+' (SSH tunnel)'; ntMySQL_ProxySQLAdmin: Result := PrefixProxysql+' (Experimental)'; ntMSSQL_NamedPipe: Result := PrefixMssql+' (named pipe)'; ntMSSQL_TCPIP: Result := PrefixMssql+' (TCP/IP)'; ntMSSQL_SPX: Result := PrefixMssql+' (SPX/IPX)'; ntMSSQL_VINES: Result := PrefixMssql+' (Banyan VINES)'; ntMSSQL_RPC: Result := PrefixMssql+' (Windows RPC)'; ntPgSQL_TCPIP: Result := PrefixPostgres+' (TCP/IP)'; ntPgSQL_SSHtunnel: Result := PrefixPostgres+' (SSH tunnel)'; ntSQLite: Result := PrefixSqlite; ntInterbase_TCPIP: Result := PrefixInterbase+' (TCP/IP, experimental)'; ntInterbase_Local: Result := PrefixInterbase+' (Local, experimental)'; ntFirebird_TCPIP: Result := PrefixFirebird+' (TCP/IP, experimental)'; ntFirebird_Local: Result := PrefixFirebird+' (Local, experimental)'; end; end else begin case NetTypeGroup of ngMySQL: begin if IsMariaDB then Result := 'MariaDB' else if IsPercona then Result := 'Percona' else if IsTokudb then Result := 'TokuDB' else if IsInfiniDB then Result := 'InfiniDB' else if IsInfobright then Result := 'Infobright' else if IsMemSQL then Result := 'MemSQL' else if IsProxySQLAdmin then Result := 'ProxySQL Admin' else if IsMySQL(True) then Result := 'MySQL' else Result := PrefixMysql; end; ngMSSQL: Result := 'MS SQL'; ngPgSQL: begin if IsRedshift then Result := PrefixRedshift else Result := PrefixPostgres; end; ngSQLite: Result := PrefixSqlite; ngInterbase: Result := PrefixInterbase; end; end; end; function TConnectionParameters.GetNetTypeGroup: TNetTypeGroup; begin case FNetType of ntMySQL_TCPIP, ntMySQL_NamedPipe, ntMySQL_SSHtunnel, ntMySQL_ProxySQLAdmin: Result := ngMySQL; ntMSSQL_NamedPipe, ntMSSQL_TCPIP, ntMSSQL_SPX, ntMSSQL_VINES, ntMSSQL_RPC: Result := ngMSSQL; ntPgSQL_TCPIP, ntPgSQL_SSHtunnel: Result := ngPgSQL; ntSQLite: Result := ngSQLite; ntInterbase_TCPIP, ntInterbase_Local, ntFirebird_TCPIP, ntFirebird_Local: Result := ngInterbase; else begin // Return default net group here. Raising an exception lets the app die for some reason. // Reproduction: click drop-down button on "Database(s)" session setting //raise EDbError.CreateFmt(_(MsgUnhandledNetType), [Integer(FNetType)]); Result := ngMySQL; end; end; end; function TConnectionParameters.IsAnyMySQL: Boolean; begin Result := NetTypeGroup = ngMySQL; end; function TConnectionParameters.IsAnyMSSQL: Boolean; begin Result := NetTypeGroup = ngMSSQL; end; function TConnectionParameters.IsAnyPostgreSQL: Boolean; begin Result := NetTypeGroup = ngPgSQL; end; function TConnectionParameters.IsAnySQLite; begin Result := NetTypeGroup = ngSQLite; end; function TConnectionParameters.IsAnyInterbase; begin Result := NetTypeGroup = ngInterbase; end; function TConnectionParameters.IsMariaDB: Boolean; begin Result := IsAnyMySQL and (Pos('-mariadb', LowerCase(ServerVersion)) > 0); end; function TConnectionParameters.IsMySQL(StrictDetect: Boolean): Boolean; begin if StrictDetect then begin Result := IsAnyMySQL and ContainsText(ServerVersion, 'mysql'); end else begin Result := IsAnyMySQL and (not IsMariaDB) and (not IsPercona) and (not IsTokudb) and (not IsInfiniDB) and (not IsInfobright) and (not IsProxySQLAdmin) and (not IsMemSQL); end; end; function TConnectionParameters.IsPercona: Boolean; begin Result := IsAnyMySQL and (Pos('percona server', LowerCase(ServerVersion)) > 0); end; function TConnectionParameters.IsTokudb: Boolean; begin Result := IsAnyMySQL and (Pos('tokudb', LowerCase(ServerVersion)) > 0); end; function TConnectionParameters.IsInfiniDB: Boolean; begin Result := IsAnyMySQL and (Pos('infinidb', LowerCase(ServerVersion)) > 0); end; function TConnectionParameters.IsInfobright: Boolean; begin Result := IsAnyMySQL and (Pos('infobright', LowerCase(ServerVersion)) > 0); end; function TConnectionParameters.IsProxySQLAdmin: Boolean; begin Result := NetType = ntMySQL_ProxySQLAdmin; end; function TConnectionParameters.IsAzure: Boolean; begin Result := IsAnyMSSQL and (Pos('azure', LowerCase(ServerVersion)) > 0); end; function TConnectionParameters.IsMemSQL: Boolean; begin Result := IsAnyMySQL and (Pos('memsql', LowerCase(ServerVersion)) > 0); end; function TConnectionParameters.IsRedshift: Boolean; begin Result := IsAnyPostgreSQL and (Pos('redshift', LowerCase(ServerVersion)) > 0); end; function TConnectionParameters.IsInterbase: Boolean; begin Result := NetType in [ntInterbase_TCPIP, ntInterbase_Local]; end; function TConnectionParameters.IsFirebird: Boolean; begin Result := NetType in [ntFirebird_TCPIP, ntFirebird_Local]; end; function TConnectionParameters.GetImageIndex: Integer; begin if IsFolder then Result := 174 else case NetTypeGroup of ngMySQL: begin Result := 164; if IsMariaDB then Result := 166 else if IsPercona then Result := 169 else if IsTokudb then Result := 171 else if IsInfiniDB then Result := 172 else if IsInfobright then Result := 173 else if IsMemSQL then Result := 194 else if IsProxySQLAdmin then Result := 197; end; ngMSSQL: begin Result := 123; if IsAzure then Result := 188; end; ngPgSQL: begin Result := 187; if IsRedshift then Result := 195; end; ngSQLite: Result := 196; ngInterbase: begin Result := 203; if IsFirebird then Result := 204; end else Result := ICONINDEX_SERVER; end; end; function TConnectionParameters.DefaultPort: Integer; begin case NetTypeGroup of ngMySQL: begin if IsProxySQLAdmin then Result := 6032 else Result := 3306; end; ngMSSQL: Result := 0; // => autodetection by driver (previously 1433) ngPgSQL: Result := 5432; ngInterbase: Result := 3050; else Result := 0; end; end; function TConnectionParameters.DefaultUsername: String; begin case NetTypeGroup of ngMySQL: Result := 'root'; ngMSSQL: Result := 'sa'; ngPgSQL: Result := 'postgres'; ngInterbase: Result := 'sysdba'; else Result := ''; end; end; function TConnectionParameters.DefaultLibrary: String; begin Result := ''; case NetTypeGroup of ngMySQL: Result := 'libmariadb.dll'; ngMSSQL: Result := 'MSOLEDBSQL'; // Prefer MSOLEDBSQL provider on newer systems ngPgSQL: Result := 'libpq.dll'; ngSQLite: Result := 'sqlite3.dll'; ngInterbase: begin if IsInterbase then Result := IfThen(GetExecutableBits=64, 'ibclient64.dll', 'gds32.dll') else if IsFirebird then Result := 'fbclient.dll'; end end; end; function TConnectionParameters.DefaultHost: string; begin // See issue #1602: SQLite connecting to IP causes out-of-memory crash Result := ''; case NetTypeGroup of ngSQLite: Result := ''; else Result := '127.0.0.1'; end; end; function TConnectionParameters.DefaultIgnoreDatabasePattern: String; begin case NetTypeGroup of ngPgSQL: Result := '^pg_temp_\d'; else Result := ''; end; end; function TConnectionParameters.GetExternalCliArguments(Connection: TDBConnection; ReplacePassword: TThreeStateBoolean): String; var Args: TStringList; begin // for mysql(dump) Args := TStringList.Create; Result := ''; if WantSSL then Args.Add('--ssl'); if not SSLPrivateKey.IsEmpty then Args.Add('--ssl-key="'+SSLPrivateKey+'"'); if not SSLCertificate.IsEmpty then Args.Add('--ssl-cert="'+SSLCertificate+'"'); if not SSLCACertificate.IsEmpty then Args.Add('--ssl-ca="'+SSLCACertificate+'"'); case NetType of ntMySQL_NamedPipe: begin Args.Add('--pipe'); Args.Add('--socket="'+Hostname+'"'); end; ntMySQL_SSHtunnel: begin Args.Add('--host="localhost"'); Args.Add('--port='+IntToStr(SSHLocalPort)); end; else begin Args.Add('--host="'+Hostname+'"'); Args.Add('--port='+IntToStr(Port)); end; end; Args.Add('--user="'+Username+'"'); if Password <> '' then begin case ReplacePassword of nbTrue: Args.Add('--password="***"'); nbFalse: Args.Add('--password="'+StringReplace(Password, '"', '\"', [rfReplaceAll])+'"'); nbUnset: Args.Add('--password'); // will prompt end; end; if Compressed then Args.Add('--compress'); if Assigned(Connection) and (Connection.Database <> '') then Args.Add('--database="' + Connection.Database + '"'); Result := ' ' + Implode(' ', Args); Args.Free; end; function TConnectionParameters.GetLibraries: TStringList; var rx: TRegExpr; Dlls: TStringDynArray; DllPath, DllFile: String; FoundLibs, Providers: TStringList; Provider: String; begin if not Assigned(FLibraries) then begin FLibraries := TNetGroupLibs.Create; end; if not FLibraries.ContainsKey(NetTypeGroup) then begin FoundLibs := TStringList.Create; rx := TRegExpr.Create; rx.ModifierI := True; case NetTypeGroup of ngMySQL: rx.Expression := '^lib(mysql|mariadb).*\.dll$'; ngMSSQL: // Allow unsupported ADODB providers per registry hack rx.Expression := IfThen(AppSettings.ReadBool(asAllProviders), '^', '^(MSOLEDBSQL|SQLOLEDB)$'); ngPgSQL: rx.Expression := '^libpq.*\.dll$'; ngSQLite: rx.Expression := '^sqlite.*\.dll$'; ngInterbase: rx.Expression := '^(gds32|ibclient|fbclient).*\.dll$'; end; case NetTypeGroup of ngMySQL, ngPgSQL, ngSQLite, ngInterbase: begin Dlls := TDirectory.GetFiles(ExtractFilePath(ParamStr(0)), '*.dll'); for DllPath in Dlls do begin DllFile := ExtractFileName(DllPath); if rx.Exec(DllFile) then begin FoundLibs.Add(DllFile); end; end; SetLength(Dlls, 0); end; ngMSSQL: begin Providers := TStringList.Create; GetProviderNames(Providers); for Provider in Providers do begin if rx.Exec(Provider) then begin FoundLibs.Add(Provider); end; end; Providers.Free; end; end; rx.Free; FLibraries.Add(NetTypeGroup, FoundLibs); end; FLibraries.TryGetValue(NetTypeGroup, Result); end; function TConnectionParameters.GetSessionName: String; var LastBackSlash: Integer; begin LastBackSlash := LastDelimiter('\', FSessionPath); if LastBackSlash > 0 then Result := Copy(FSessionPath, LastBackSlash+1, MaxInt) else Result := FSessionPath; end; { TMySQLConnection } constructor TDBConnection.Create(AOwner: TComponent); begin inherited; FParameters := TConnectionParameters.Create; FRowsFound := 0; FRowsAffected := 0; FWarningCount := 0; FConnectionStarted := 0; FDatabase := ''; FLastQueryDuration := 0; FLastQueryNetworkDuration := 0; FThreadID := 0; FLogPrefix := ''; FIsUnicode := True; FIsSSL := False; FDatabaseCache := TDatabaseCache.Create(True); FColumnCache := TColumnCache.Create; FKeyCache := TKeyCache.Create; FForeignKeyCache := TForeignKeyCache.Create; FCheckConstraintCache := TCheckConstraintCache.Create; FLoginPromptDone := False; FCurrentUserHostCombination := ''; FKeepAliveTimer := TTimer.Create(Self); FFavorites := TStringList.Create; FForeignKeyQueriesFailed := False; // System database/schema, should be uppercase on MSSQL only, see #855 FInfSch := 'information_schema'; FInformationSchemaObjects := TStringList.Create; FInformationSchemaObjects.CaseSensitive := False; // Characters in identifiers which don't need to be quoted FIdentCharsNoQuote := ['A'..'Z', 'a'..'z', '0'..'9', '_']; FMaxRowsPerInsert := 10000; FCaseSensitivity := 0; FStringQuoteChar := ''''; end; constructor TMySQLConnection.Create(AOwner: TComponent); var i: Integer; begin inherited; FQuoteChar := '`'; FQuoteChars := '`"'; FStatementNum := 0; // The compiler complains that dynamic and static arrays are incompatible, so this does not work: // FDatatypes := MySQLDatatypes SetLength(FDatatypes, Length(MySQLDatatypes)); for i:=0 to High(MySQLDatatypes) do FDatatypes[i] := MySQLDatatypes[i]; end; constructor TAdoDBConnection.Create(AOwner: TComponent); var i: Integer; begin inherited; FQuoteChar := '"'; FQuoteChars := '"[]'; SetLength(FDatatypes, Length(MSSQLDatatypes)); for i:=0 to High(MSSQLDatatypes) do FDatatypes[i] := MSSQLDatatypes[i]; FInfSch := 'INFORMATION_SCHEMA'; FMaxRowsPerInsert := 1000; end; constructor TPgConnection.Create(AOwner: TComponent); var i: Integer; begin inherited; FQuoteChar := '"'; FQuoteChars := '"'; SetLength(FDatatypes, Length(PostGreSQLDatatypes)); for i:=0 to High(PostGreSQLDatatypes) do FDatatypes[i] := PostGreSQLDatatypes[i]; // cache for 123::regclass queries: FRegClasses := TOidStringPairs.Create; // Identifiers with uppercase characters must be quoted, see #1072 FIdentCharsNoQuote := ['a'..'z', '0'..'9', '_']; end; constructor TSQLiteConnection.Create(AOwner: TComponent); var i: Integer; begin inherited; FQuoteChar := '"'; FQuoteChars := '"[]'; SetLength(FDatatypes, Length(SQLiteDatatypes)); for i:=0 to High(SQLiteDatatypes) do FDatatypes[i] := SQLiteDatatypes[i]; // SQLite does not have IS: FInfSch := ''; end; constructor TInterbaseConnection.Create(AOwner: TComponent); var i: Integer; begin inherited; FQuoteChar := '"'; FQuoteChars := '"[]'; SetLength(FDatatypes, Length(InterbaseDatatypes)); for i:=0 to High(InterbaseDatatypes) do FDatatypes[i] := InterbaseDatatypes[i]; // Interbase does not have IS: FInfSch := ''; end; destructor TDBConnection.Destroy; begin ClearCache(True); FKeepAliveTimer.Free; FFavorites.Free; FInformationSchemaObjects.Free; inherited; end; destructor TMySQLConnection.Destroy; begin if Active then Active := False; FLib.Free; inherited; end; destructor TAdoDBConnection.Destroy; begin if Active then Active := False; FreeAndNil(FAdoHandle); inherited; end; destructor TPgConnection.Destroy; begin if Active then Active := False; FRegClasses.Free; FLib.Free; inherited; end; destructor TSQLiteConnection.Destroy; begin if Active then Active := False; FLib.Free; inherited; end; destructor TInterbaseConnection.Destroy; begin if Active then Active := False; FreeAndNil(FFdHandle); inherited; end; function TDBConnection.GetDatatypeByName(var DataType: String; DeleteFromSource: Boolean; Identifier: String=''): TDBDatatype; var i, MatchLen: Integer; Match: Boolean; rx: TRegExpr; Types, tmp: String; TypesSorted: TStringList; begin rx := TRegExpr.Create; rx.ModifierI := True; MatchLen := 0; for i:=0 to High(FDatatypes) do begin Types := FDatatypes[i].Name; if FDatatypes[i].Names <> '' then begin Types := Types + '|' + FDatatypes[i].Names; // Move more exact (longer) types to the beginning TypesSorted := Explode('|', Types); TypesSorted.CustomSort(StringListCompareByLength); Types := Implode('|', TypesSorted); TypesSorted.Free; end; rx.Expression := '^('+Types+')\b(\[\])?'; Match := rx.Exec(DataType); // Prefer a later match which is longer than the one found before. // See http://www.heidisql.com/forum.php?t=17061 if Match and (rx.MatchLen[1] > MatchLen) then begin Log(lcDebug, 'GetDatatypeByName: "'+DataType+'" : '+rx.Match[1]); if (FParameters.NetTypeGroup = ngPgSQL) and (rx.MatchLen[2] > 0) then begin // TODO: detect array style datatypes, e.g. TEXT[] end else begin MatchLen := rx.MatchLen[1]; Result := FDatatypes[i]; end; end; end; if (MatchLen > 0) and DeleteFromSource then begin Delete(DataType, 1, MatchLen); end; if MatchLen = 0 then begin // Fall back to unknown type Result := Datatypes[0]; rx.Expression := '^(\S+)'; if rx.Exec(DataType) then tmp := rx.Match[1] else tmp := DataType; if Identifier <> '' then Log(lcError, f_('Unknown datatype "%0:s" for "%1:s". Fall back to %2:s.', [tmp, Identifier, Result.Name])) else Log(lcError, f_('Unknown datatype "%0:s". Fall back to %1:s.', [tmp, Result.Name])); end; rx.Free; end; function TDBConnection.GetDatatypeByNativeType(NativeType: Integer; Identifier: String=''): TDBDatatype; var i: Integer; rx: TRegExpr; TypeFound: Boolean; begin rx := TRegExpr.Create; TypeFound := False; for i:=0 to High(Datatypes) do begin if Datatypes[i].NativeTypes = '' then Continue; rx.Expression := '\b('+Datatypes[i].NativeTypes+')\b'; if rx.Exec(IntToStr(NativeType)) then begin Result := Datatypes[i]; TypeFound := True; break; end; end; if not TypeFound then begin // Fall back to unknown type Result := Datatypes[0]; if Identifier <> '' then Log(lcError, f_('Unknown datatype oid #%0:d for "%1:s". Fall back to %2:s.', [NativeType, Identifier, Result.Name])) else Log(lcError, f_('Unknown datatype oid #%0:d. Fall back to %1:s.', [NativeType, Result.Name])); end; end; procedure TDBConnection.SetLockedByThread(Value: TThread); begin FLockedByThread := Value; end; procedure TMySQLConnection.SetLockedByThread(Value: TThread); begin if Value <> FLockedByThread then begin if Value <> nil then begin // We're running in a thread already. Ensure that Log() is able to detect that. FLockedByThread := Value; Log(lcDebug, 'mysql_thread_init, thread id #'+IntToStr(Value.ThreadID)); FLib.mysql_thread_init; end else begin FLib.mysql_thread_end; Log(lcDebug, 'mysql_thread_end, thread id #'+IntToStr(FLockedByThread.ThreadID)); FLockedByThread := Value; end; end; end; {** (Dis-)Connect to/from server } procedure TMySQLConnection.SetActive( Value: Boolean ); var Connected: PMYSQL; ClientFlags, FinalPort: Integer; Error, StatusName: String; FinalHost, FinalSocket, FinalUsername, FinalPassword: String; ErrorHint: String; sslca, sslkey, sslcert, sslcipher: PAnsiChar; PluginDir: AnsiString; Status: TDBQuery; PasswordChangeDialog: TfrmPasswordChange; SetOptionResult: Integer; UserNameSize: DWORD; begin if Value and (FHandle = nil) then begin DoBeforeConnect; // Get handle FHandle := FLib.mysql_init(nil); // Prepare special stuff for SSL and SSH tunnel FinalHost := FParameters.Hostname; FinalSocket := ''; FinalPort := FParameters.Port; if FParameters.WantSSL then begin // mysql_ssl_set() wants nil, while PAnsiChar(AnsiString()) is never nil sslkey := nil; sslcert := nil; sslca := nil; sslcipher := nil; if FParameters.SSLPrivateKey <> '' then sslkey := PAnsiChar(AnsiString(FParameters.SSLPrivateKey)); if FParameters.SSLCertificate <> '' then sslcert := PAnsiChar(AnsiString(FParameters.SSLCertificate)); if FParameters.SSLCACertificate <> '' then sslca := PAnsiChar(AnsiString(FParameters.SSLCACertificate)); if FParameters.SSLCipher <> '' then sslcipher := PAnsiChar(AnsiString(FParameters.SSLCipher)); { TODO : Use Cipher and CAPath parameters } FLib.mysql_ssl_set(FHandle, sslkey, sslcert, sslca, nil, sslcipher); Log(lcInfo, _('SSL parameters successfully set.')); end; case FParameters.NetType of ntMySQL_TCPIP, ntMySQL_ProxySQLAdmin: begin end; ntMySQL_NamedPipe: begin FinalHost := '.'; FinalSocket := FParameters.Hostname; end; ntMySQL_SSHtunnel: begin // Create SSH process FSecureShellCmd := TSecureShellCmd.Create(Self); FSecureShellCmd.Connect; FinalHost := '127.0.0.1'; FinalPort := FParameters.SSHLocalPort; end; end; // User/Password if FParameters.WindowsAuth then begin // Send Windows system user name and blank password, see #991 UserNameSize := 1024; SetLength(FinalUsername, UserNameSize); if GetUserName(PChar(FinalUsername), UserNameSize) then SetLength(FinalUsername, UserNameSize-1) else RaiseLastOSError; FinalPassword := ''; end else begin // Normal mode, send user specified user/password FinalUsername := FParameters.Username; FinalPassword := FParameters.Password; end; // Gather client options ClientFlags := CLIENT_LOCAL_FILES or CLIENT_INTERACTIVE or CLIENT_PROTOCOL_41 or CLIENT_MULTI_STATEMENTS or CLIENT_CAN_HANDLE_EXPIRED_PASSWORDS or CLIENT_PLUGIN_AUTH_LENENC_CLIENT_DATA; if Parameters.Compressed then ClientFlags := ClientFlags or CLIENT_COMPRESS; if Parameters.WantSSL then ClientFlags := ClientFlags or CLIENT_SSL; // Point libmysql to the folder with client plugins PluginDir := AnsiString(ExtractFilePath(ParamStr(0))+'plugins'); SetOptionResult := FLib.mysql_options(FHandle, Integer(MYSQL_PLUGIN_DIR), PAnsiChar(PluginDir)); if SetOptionResult <> 0 then begin raise EDbError.Create(f_('Plugin directory %s could not be set.', [PluginDir])); end; // Define which TLS protocol versions are allowed. // See https://www.heidisql.com/forum.php?t=27158 // See https://mariadb.com/kb/en/library/mysql_optionsv/ FLib.mysql_options(FHandle, Integer(MARIADB_OPT_TLS_VERSION), PAnsiChar('TLSv1,TLSv1.1,TLSv1.2,TLSv1.3')); FLib.mysql_options(FHandle, Integer(MYSQL_OPT_TLS_VERSION), PAnsiChar('TLSv1,TLSv1.1,TLSv1.2,TLSv1.3')); // Enable cleartext plugin if Parameters.CleartextPluginEnabled then FLib.mysql_options(FHandle, Integer(MYSQL_ENABLE_CLEARTEXT_PLUGIN), PAnsiChar('1')); // Tell server who we are if Assigned(FLib.mysql_optionsv) then FLib.mysql_optionsv(FHandle, Integer(MYSQL_OPT_CONNECT_ATTR_ADD), 'program_name', APPNAME); // Seems to be still required on some systems, for importing CSV files FLib.mysql_options(FHandle, Integer(MYSQL_OPT_LOCAL_INFILE), PAnsiChar('1')); // Ensure we have some connection timeout FLib.mysql_options(FHandle, Integer(MYSQL_OPT_CONNECT_TIMEOUT), @FParameters.QueryTimeout); Connected := FLib.mysql_real_connect( FHandle, PAnsiChar(Utf8Encode(FinalHost)), PAnsiChar(Utf8Encode(FinalUsername)), PAnsiChar(Utf8Encode(FinalPassword)), nil, FinalPort, PAnsiChar(Utf8Encode(FinalSocket)), ClientFlags ); if Connected = nil then begin Error := LastErrorMsg; Log(lcError, Error); FConnectionStarted := 0; FHandle := nil; if FSecureShellCmd <> nil then FSecureShellCmd.Free; if (FParameters.DefaultLibrary <> '') and (FParameters.LibraryOrProvider <> FParameters.DefaultLibrary) then begin ErrorHint := f_('You could try the default library %s in your session settings. (Current: %s)', [FParameters.DefaultLibrary, FParameters.LibraryOrProvider] ); end else begin ErrorHint := ''; end; raise EDbError.Create(Error, LastErrorCode, ErrorHint); end else begin FActive := True; // Catch late init_connect error by firing mysql_ping(), which detects a broken // connection without running into some access violation. See issue #3464. Ping(False); if not FActive then raise EDbError.CreateFmt(_('Connection closed immediately after it was established. '+ 'This is mostly caused by an "%s" server variable which has errors in itself, '+ 'or your user account does not have the required privileges for it to run.'+CRLF+CRLF+ 'You may ask someone with SUPER privileges'+CRLF+ '* either to fix the "%s" variable,'+CRLF+ '* or to grant you missing privileges.'), ['init_connect', 'init_connect']); // Try to fire the very first query against the server, which probably run into the following error: // "Error 1820: You must SET PASSWORD before executing this statement" try ThreadId; except on E:EDbError do begin if GetLastErrorCode = ER_MUST_CHANGE_PASSWORD then begin PasswordChangeDialog := TfrmPasswordChange.Create(Self); PasswordChangeDialog.lblHeading.Caption := GetLastErrorMsg; PasswordChangeDialog.ShowModal; if PasswordChangeDialog.ModalResult = mrOk then begin if ExecRegExpr('\sALTER USER\s', GetLastErrorMsg) then Query('ALTER USER USER() IDENTIFIED BY '+EscapeString(PasswordChangeDialog.editPassword.Text)) else Query('SET PASSWORD=PASSWORD('+EscapeString(PasswordChangeDialog.editPassword.Text)+')'); end else // Dialog cancelled Raise; PasswordChangeDialog.Free; end else Raise; end; end; // We need the server version before checking the current character set FServerVersionUntouched := GetSessionVariable('version') + ' - ' + GetSessionVariable('version_comment'); FServerVersionUntouched := FServerVersionUntouched.Trim([' ', '-']); if FServerVersionUntouched.IsEmpty then begin FServerVersionUntouched := DecodeAPIString(FLib.mysql_get_server_info(FHandle)); end; // mysql_character_set_name() reports utf8* if in fact we're on some latin* charset on v5.1 servers // See https://www.heidisql.com/forum.php?t=39278 FIsUnicode := CharacterSet.StartsWith('utf', True) and (ServerVersionInt >= 50500); if not IsUnicode then try CharacterSet := 'utf8mb4'; except // older servers without *mb4 support go here on E:EDbError do try Log(lcError, E.Message); CharacterSet := 'utf8'; except // v5.1 returned "Unknown character set: 'utf8mb3'" with libmariadb on E:EDbError do try Log(lcError, E.Message); Query('SET NAMES utf8'); except // give up on E:EDbError do Log(lcError, E.Message); end; end; end; Log(lcInfo, _('Characterset')+': '+CharacterSet); FConnectionStarted := GetTickCount div 1000; FServerUptime := -1; Status := GetResults(GetSQLSpecifity(spGlobalStatus)); while not Status.Eof do begin StatusName := LowerCase(Status.Col(0)); if (StatusName = 'uptime') or (StatusName = 'proxysql_uptime') then FServerUptime := StrToIntDef(Status.Col(1), FServerUptime) else if StatusName = 'ssl_cipher' then FIsSSL := Status.Col(1) <> ''; Status.Next; end; FServerDateTimeOnStartup := GetVar('SELECT ' + GetSQLSpecifity(spFuncNow)); FServerOS := GetSessionVariable('version_compile_os'); FRealHostname := GetSessionVariable('hostname'); FCaseSensitivity := MakeInt(GetSessionVariable('lower_case_table_names', IntToStr(FCaseSensitivity))); // Triggers OnDatabaseChange event for Database := ''; DoAfterConnect; end; end else if (not Value) and (FHandle <> nil) then begin try FLib.mysql_close(FHandle); except on E:Exception do // sometimes fails with libmysql-6.1.dll, see #980 Log(lcError, 'Error while closing handle: '+E.Message); end; FActive := False; ClearCache(False); FConnectionStarted := 0; FHandle := nil; if FSecureShellCmd <> nil then FSecureShellCmd.Free; Log(lcInfo, f_(MsgDisconnect, [FParameters.Hostname, DateTimeToStr(Now)])); end; end; procedure TAdoDBConnection.SetActive(Value: Boolean); var Error, NetLib, DataSource, QuotedPassword, ServerVersion, ErrorHint: String; rx: TRegExpr; i: Integer; IsOldProvider: Boolean; begin if Value then begin DoBeforeConnect; try // Creating the ADO object throws exceptions if MDAC is missing, especially on Wine FAdoHandle := TAdoConnection.Create(Owner); except on E:Exception do raise EDbError.Create(E.Message+CRLF+CRLF+ _('On Wine, you can try to install MDAC:')+CRLF+ '> wget http://winetricks.org/winetricks'+CRLF+ '> chmod +x winetricks'+CRLF+ '> sh winetricks mdac28'+CRLF+ '> sh winetricks native_mdac'); end; IsOldProvider := Parameters.LibraryOrProvider = 'SQLOLEDB'; if IsOldProvider then begin MessageDialog( f_('Security issue: Using %s %s with insecure %s.', [Parameters.LibraryOrProvider, 'ADO provider', 'TLS 1.0']) + f_('You should install %s from %s', ['Microsoft OLE DB Driver', 'https://www.microsoft.com/en-us/download/confirmation.aspx?id=56730']), mtWarning, [mbOK]); end; NetLib := ''; case Parameters.NetType of ntMSSQL_NamedPipe: NetLib := 'DBNMPNTW'; ntMSSQL_TCPIP: NetLib := 'DBMSSOCN'; ntMSSQL_SPX: NetLib := 'DBMSSPXN'; ntMSSQL_VINES: NetLib := 'DBMSVINN'; ntMSSQL_RPC: NetLib := 'DBMSRPCN'; end; DataSource := Parameters.Hostname; if (Parameters.NetType = ntMSSQL_TCPIP) and (Parameters.Port <> 0) then DataSource := DataSource + ','+IntToStr(Parameters.Port); // Quote password, just in case there is a semicolon or a double quote in it. // See http://forums.asp.net/t/1957484.aspx?Passwords+ending+with+semi+colon+as+the+terminal+element+in+connection+strings+ if Pos('"', Parameters.Password) > 0 then QuotedPassword := ''''+Parameters.Password+'''' else QuotedPassword := '"'+Parameters.Password+'"'; FAdoHandle.ConnectionString := 'Provider='+Parameters.LibraryOrProvider+';'+ 'Password='+QuotedPassword+';'+ 'Persist Security Info=True;'+ 'User ID='+Parameters.Username+';'+ 'Network Library='+NetLib+';'+ 'Data Source='+DataSource+';'+ 'Application Name='+AppName+';' ; if Parameters.LibraryOrProvider = 'MSOLEDBSQL' then begin // Issue #423: MSOLEDBSQL compatibility with new column types // See https://docs.microsoft.com/en-us/sql/connect/oledb/applications/using-ado-with-oledb-driver-for-sql-server?view=sql-server-2017 // Do not use with old driver, see https://www.heidisql.com/forum.php?t=35208 FAdoHandle.ConnectionString := FAdoHandle.ConnectionString + 'DataTypeCompatibility=80;'; end; // Pass Database setting to connection string. Required on MS Azure? if (not Parameters.AllDatabasesStr.IsEmpty) and (Pos(';', Parameters.AllDatabasesStr)=0) then FAdoHandle.ConnectionString := FAdoHandle.ConnectionString + 'Database='+Parameters.AllDatabasesStr+';'; if Parameters.WindowsAuth then begin if IsOldProvider then FAdoHandle.ConnectionString := FAdoHandle.ConnectionString + 'Integrated Security=SSPI;' else FAdoHandle.ConnectionString := FAdoHandle.ConnectionString + 'Trusted_Connection=yes;' end; try FAdoHandle.Connected := True; FConnectionStarted := GetTickCount div 1000; FActive := True; // No need to set a charset for MS SQL // CharacterSet := 'utf8'; // CurCharset := CharacterSet; // Log(lcDebug, 'Characterset: '+CurCharset); FAdoHandle.CommandTimeout := Parameters.QueryTimeout; try // Gracefully accept failure on MS Azure (SQL Server 11), which does not have a sysprocesses table FServerUptime := StrToIntDef(GetVar('SELECT DATEDIFF(SECOND, '+QuoteIdent('login_time')+', CURRENT_TIMESTAMP) FROM '+QuoteIdent('master')+'.'+QuoteIdent('dbo')+'.'+QuoteIdent('sysprocesses')+' WHERE '+QuoteIdent('spid')+'=1'), -1); except FServerUptime := -1; end; FServerDateTimeOnStartup := GetVar('SELECT ' + GetSQLSpecifity(spFuncNow)); // Microsoft SQL Server 2008 R2 (RTM) - 10.50.1600.1 (Intel X86) // Apr 2 2010 15:53:02 // Copyright (c) Microsoft Corporation // Express Edition with Advanced Services on Windows NT 6.1 (Build 7600: ) FServerVersionUntouched := Trim(GetVar('SELECT @@VERSION')); rx := TRegExpr.Create; rx.ModifierI := False; // Extract server OS rx.Expression := '\s+on\s+([^\r\n]+)'; if rx.Exec(FServerVersionUntouched) then FServerOS := rx.Match[1]; // Cut at first line break rx.Expression := '^([^\r\n]+)'; if rx.Exec(FServerVersionUntouched) then FServerVersionUntouched := rx.Match[1]; try // Try to get more exact server version to avoid displaying "20.14" in some cases ServerVersion := GetVar('SELECT SERVERPROPERTY('+EscapeString('ProductVersion')+')'); if ExecRegExpr('(\d+)\.(\d+)\.(\d+)\.(\d+)', ServerVersion) then FServerVersionUntouched := Copy(FServerVersionUntouched, 1, Pos(' - ', FServerVersionUntouched)+2) + ServerVersion; except // Above query only works on SQL Server 2008 and newer // Keep value from SELECT @@VERSION on older servers end; rx.Free; // See http://www.heidisql.com/forum.php?t=19779 Query('SET TEXTSIZE 2147483647'); FRealHostname := Parameters.Hostname; // Show up dynamic connection properties, probably useful for debugging for i:=0 to FAdoHandle.Properties.Count-1 do Log(lcDebug, f_('OLE DB property "%s": %s', [FAdoHandle.Properties[i].Name, String(FAdoHandle.Properties[i].Value)])); // Triggers OnDatabaseChange event for Database := ''; DoAfterConnect; // Reopen closed datasets after reconnecting // ... does not work for some reason. Still getting "not allowed on a closed object" errors in grid. //for i:=0 to FAdoHandle.DataSetCount-1 do // FAdoHandle.DataSets[i].Open; except on E:Exception do begin FLastError := E.Message; Error := LastErrorMsg; Log(lcError, Error); FConnectionStarted := 0; if (FParameters.DefaultLibrary <> '') and (FParameters.LibraryOrProvider <> FParameters.DefaultLibrary) then begin ErrorHint := f_('You could try the default library %s in your session settings. (Current: %s)', [FParameters.DefaultLibrary, FParameters.LibraryOrProvider] ); end else begin ErrorHint := ''; end; raise EDbError.Create(Error, LastErrorCode, ErrorHint); end; end; end else begin FAdoHandle.Connected := False; FActive := False; ClearCache(False); FConnectionStarted := 0; Log(lcInfo, f_(MsgDisconnect, [FParameters.Hostname, DateTimeToStr(Now)])); end; end; procedure TPgConnection.SetActive(Value: Boolean); var dbname, ConnInfo, Error: String; FinalHost, ErrorHint: String; FinalPort: Integer; function EscapeConnectOption(Option: String): String; begin // See issue #704 and #1417, and docs: https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING Result := StringReplace(Option, '\', '\\', [rfReplaceAll]); Result := StringReplace(Result, '''', '\''', [rfReplaceAll]); end; begin if Value then begin DoBeforeConnect; // Simon Riggs: // "You should connect as "postgres" database by default, with an option to change. Don't use template1" dbname := FParameters.AllDatabasesStr; if dbname = '' then dbname := 'postgres'; // Prepare special stuff for SSH tunnel FinalHost := FParameters.Hostname; FinalPort := FParameters.Port; case FParameters.NetType of ntPgSQL_SSHtunnel: begin // Create SSH process FSecureShellCmd := TSecureShellCmd.Create(Self); FSecureShellCmd.Connect; FinalHost := '127.0.0.1'; FinalPort := FParameters.SSHLocalPort; end; end; ConnInfo := 'host='''+EscapeConnectOption(FinalHost)+''' '+ 'port='''+IntToStr(FinalPort)+''' '+ 'user='''+EscapeConnectOption(FParameters.Username)+''' ' + 'password='''+EscapeConnectOption(FParameters.Password)+''' '+ 'dbname='''+EscapeConnectOption(dbname)+''' '+ 'application_name='''+EscapeConnectOption(APPNAME)+''''; if FParameters.WantSSL then begin ConnInfo := ConnInfo + ' sslmode=''require'''; if FParameters.SSLPrivateKey <> '' then ConnInfo := ConnInfo + ' sslkey='''+EscapeConnectOption(FParameters.SSLPrivateKey)+''''; if FParameters.SSLCertificate <> '' then ConnInfo := ConnInfo + ' sslcert='''+EscapeConnectOption(FParameters.SSLCertificate)+''''; if FParameters.SSLCACertificate <> '' then ConnInfo := ConnInfo + ' sslrootcert='''+EscapeConnectOption(FParameters.SSLCACertificate)+''''; //if FParameters.SSLCipher <> '' then ?? end; FHandle := FLib.PQconnectdb(PAnsiChar(AnsiString(ConnInfo))); if FLib.PQstatus(FHandle) = CONNECTION_BAD then begin Error := LastErrorMsg; Log(lcError, Error); FConnectionStarted := 0; try FLib.PQfinish(FHandle); // free the memory except on E:EAccessViolation do; end; FHandle := nil; if FSecureShellCmd <> nil then FSecureShellCmd.Free; if (FParameters.DefaultLibrary <> '') and (FParameters.LibraryOrProvider <> FParameters.DefaultLibrary) then begin ErrorHint := f_('You could try the default library %s in your session settings. (Current: %s)', [FParameters.DefaultLibrary, FParameters.LibraryOrProvider] ); end else begin ErrorHint := ''; end; raise EDbError.Create(Error, LastErrorCode, ErrorHint); end; FActive := True; FServerDateTimeOnStartup := GetVar('SELECT ' + GetSQLSpecifity(spFuncNow)); FServerVersionUntouched := GetVar('SELECT VERSION()'); FConnectionStarted := GetTickCount div 1000; Query('SET statement_timeout TO '+IntToStr(Parameters.QueryTimeout*1000)); try FServerUptime := StrToIntDef(GetVar('SELECT EXTRACT(EPOCH FROM CURRENT_TIMESTAMP - pg_postmaster_start_time())::INTEGER'), -1); except FServerUptime := -1; end; try FIsSSL := LowerCase(GetVar('SHOW ssl')) = 'on'; except FIsSSL := False; end; // Triggers OnDatabaseChange event for Database := ''; DoAfterConnect; end else begin try FLib.PQfinish(FHandle); except on E:EAccessViolation do; end; FActive := False; ClearCache(False); FConnectionStarted := 0; if FSecureShellCmd <> nil then FSecureShellCmd.Free; Log(lcInfo, f_(MsgDisconnect, [FParameters.Hostname, DateTimeToStr(Now)])); end; end; procedure TSQLiteConnection.SetActive(Value: Boolean); var ConnectResult: Integer; ErrorHint: String; FileNames: TStringList; MainFile, DbAlias: String; i: Integer; begin // Support multiple filenames, and use first one as main database FileNames := Explode(DELIM, Parameters.Hostname); MainFile := IfThen(FileNames.Count>=1, FileNames[0], ''); if Value then begin DoBeforeConnect; ConnectResult := FLib.sqlite3_open( PAnsiChar(Utf8Encode(MainFile)), FHandle); if ConnectResult = SQLITE_OK then begin FActive := True; FLib.sqlite3_collation_needed(FHandle, Self, SQLite_CollationNeededCallback); Query('PRAGMA busy_timeout='+(Parameters.QueryTimeout*1000).ToString); // Override "main" database name with custom one FMainDbName := UTF8Encode(TPath.GetFileNameWithoutExtension(MainFile)); if FLib.sqlite3_db_config(FHandle, SQLITE_DBCONFIG_MAINDBNAME, PAnsiChar(FMainDbName)) <> SQLITE_OK then begin Log(lcError, 'Could not set custom name of "main" database to "' + UTF8ToString(FMainDbName) + '"'); end; // Attach additional databases for i:=1 to FileNames.Count-1 do begin DbAlias := TPath.GetFileNameWithoutExtension(FileNames[i]); Query('ATTACH DATABASE '+EscapeString(FileNames[i])+' AS '+QuoteIdent(DbAlias)); end; // See issue #1186: if FLib.sqlite3_enable_load_extension(FHandle, 1) <> SQLITE_OK then begin Log(lcError, 'Could not enable load_extension()'); end; FServerDateTimeOnStartup := GetVar('SELECT ' + GetSQLSpecifity(spFuncNow)); FServerVersionUntouched := GetVar('SELECT sqlite_version()'); FConnectionStarted := GetTickCount div 1000; FServerUptime := -1; // Triggers OnDatabaseChange event for Database := ''; DoAfterConnect; end else begin Log(lcError, LastErrorMsg); FConnectionStarted := 0; FHandle := nil; if (FParameters.DefaultLibrary <> '') and (FParameters.LibraryOrProvider <> FParameters.DefaultLibrary) then begin ErrorHint := f_('You could try the default library %s in your session settings. (Current: %s)', [FParameters.DefaultLibrary, FParameters.LibraryOrProvider] ); end else begin ErrorHint := ''; end; raise EDbError.Create(LastErrorMsg); end; end else begin if FHandle <> nil then begin ClearCache(False); FLib.sqlite3_close(FHandle); FHandle := nil; FActive := False; Log(lcInfo, f_(MsgDisconnect, [MainFile, DateTimeToStr(Now)])); end; end; end; procedure TInterbaseConnection.SetActive(Value: Boolean); var DriverId: String; IbDriver: TFDPhysIBDriverLink; FbDriver: TFDPhysFBDriverLink; begin if Value then begin DoBeforeConnect; FFDHandle := TFDConnection.Create(Owner); FFDHandle.OnError := OnFdError; //FFDHandle.DriverName := Parameters.LibraryOrProvider; // Auto-sets Params.DriverID FFDHandle.LoginPrompt := False; // Create virtual Interbase or Firebird driver id, once DriverId := Parameters.LibraryOrProvider; if Parameters.IsInterbase then begin if not Assigned(FIbDrivers) then begin FIbDrivers := TIbDrivers.Create; end; if not FIbDrivers.ContainsKey(DriverId) then begin Log(lcInfo, 'Creating virtual driver id with '+Parameters.LibraryOrProvider); IbDriver := TFDPhysIBDriverLink.Create(Owner); IbDriver.VendorLib := Parameters.LibraryOrProvider; IbDriver.DriverID := DriverId; FIbDrivers.Add(DriverId, IbDriver); end; FIbDrivers.TryGetValue(DriverId, IbDriver); FFDHandle.Params.Values['DriverID'] := IbDriver.DriverID; end else if Parameters.IsFirebird then begin if not Assigned(FFbDrivers) then begin FFbDrivers := TFbDrivers.Create; end; if not FFbDrivers.ContainsKey(DriverId) then begin Log(lcInfo, 'Creating virtual driver id link with '+Parameters.LibraryOrProvider); FbDriver := TFDPhysFBDriverLink.Create(Owner); FbDriver.VendorLib := Parameters.LibraryOrProvider; FbDriver.DriverID := DriverId; FFbDrivers.Add(DriverId, FbDriver); end; FFbDrivers.TryGetValue(DriverId, FbDriver); FFDHandle.Params.Values['DriverID'] := FbDriver.DriverID; end; // TCP/IP or local? case Parameters.NetType of ntInterbase_TCPIP, ntFirebird_TCPIP: begin FFDHandle.Params.Values['Protocol'] := 'ipTCPIP'; FFDHandle.Params.Values['Server'] := Parameters.Hostname; FFDHandle.Params.Values['Port'] := Parameters.Port.ToString; end; ntInterbase_Local, ntFirebird_Local: begin FFDHandle.Params.Values['Protocol'] := 'ipLocal'; end; end; FFDHandle.Params.Values['Database'] := Parameters.AllDatabasesStr; FFDHandle.Params.Values['User_Name'] := Parameters.Username; FFDHandle.Params.Values['Password'] := Parameters.Password; FFDHandle.Params.Values['CharacterSet'] := 'UTF8'; FFDHandle.Params.Values['ExtendedMetadata'] := 'True'; try FFDHandle.Connected := True; except // Let OnFdError set FLastError end; if FFDHandle.Connected then begin FActive := True; //! Query('PRAGMA busy_timeout='+(Parameters.QueryTimeout*1000).ToString); FServerDateTimeOnStartup := GetVar('SELECT ' + GetSQLSpecifity(spFuncNow)); if Parameters.IsInterbase then FServerVersionUntouched := '' else FServerVersionUntouched := GetVar('SELECT rdb$get_context(''SYSTEM'', ''ENGINE_VERSION'') as version from rdb$database'); FConnectionStarted := GetTickCount div 1000; FServerUptime := -1; // Triggers OnDatabaseChange event for Database := ''; DoAfterConnect; end else begin Log(lcError, LastErrorMsg); FConnectionStarted := 0; raise EDbError.Create(LastErrorMsg); end; end else begin if FFdHandle <> nil then begin ClearCache(False); FFdHandle.Connected := False; FActive := False; Log(lcInfo, f_(MsgDisconnect, [Parameters.Hostname, DateTimeToStr(Now)])); end; end; end; procedure TDBConnection.DoBeforeConnect; var UsingPass: String; Dialog: TfrmLogin; begin // Prompt for password on initial connect if FParameters.LoginPrompt and (not FLoginPromptDone) then begin Dialog := TfrmLogin.Create(Self); Dialog.Caption := APPNAME + ' - ' + FParameters.SessionName; Dialog.lblPrompt.Caption := f_('Login to %s:', [FParameters.Hostname]); Dialog.editUsername.Text := FParameters.Username; Dialog.editPassword.Text := FParameters.Password; Dialog.ShowModal; FParameters.Username := Dialog.editUsername.Text; FParameters.Password := Dialog.editPassword.Text; Dialog.Free; FLoginPromptDone := True; end; // Prepare connection if FParameters.Password <> '' then UsingPass := 'Yes' else UsingPass := 'No'; Log(lcInfo, f_('Connecting to %s via %s, username %s, using password: %s ...', [FParameters.Hostname, FParameters.NetTypeName(True), FParameters.Username, UsingPass] )); case Parameters.NetTypeGroup of ngMySQL: begin FSQLSpecifities[spDatabaseDrop] := 'DROP DATABASE %s'; FSQLSpecifities[spEmptyTable] := 'TRUNCATE '; FSQLSpecifities[spRenameTable] := 'RENAME TABLE %s TO %s'; FSQLSpecifities[spRenameView] := FSQLSpecifities[spRenameTable]; FSQLSpecifities[spCurrentUserHost] := 'SELECT CURRENT_USER()'; FSQLSpecifities[spLikeCompare] := '%s LIKE %s'; FSQLSpecifities[spAddColumn] := 'ADD COLUMN %s'; FSQLSpecifities[spChangeColumn] := 'CHANGE COLUMN %s %s'; FSQLSpecifities[spGlobalStatus] := IfThen( Parameters.IsProxySQLAdmin, 'SELECT * FROM stats_mysql_global', 'SHOW /*!50002 GLOBAL */ STATUS' ); FSQLSpecifities[spCommandsCounters] := IfThen( Parameters.IsProxySQLAdmin, 'SELECT * FROM stats_mysql_commands_counters', 'SHOW /*!50002 GLOBAL */ STATUS LIKE ''Com\_%''' ); FSQLSpecifities[spSessionVariables] := 'SHOW VARIABLES'; FSQLSpecifities[spGlobalVariables] := 'SHOW GLOBAL VARIABLES'; FSQLSpecifities[spISSchemaCol] := '%s_SCHEMA'; FSQLSpecifities[spUSEQuery] := 'USE %s'; FSQLSpecifities[spKillQuery] := 'KILL %d'; FSQLSpecifities[spKillProcess] := 'KILL %d'; FSQLSpecifities[spFuncLength] := 'LENGTH'; FSQLSpecifities[spFuncCeil] := 'CEIL'; FSQLSpecifities[spFuncLeft] := IfThen(Parameters.IsProxySQLAdmin, 'SUBSTR(%s, 1, %d)', 'LEFT(%s, %d)'); FSQLSpecifities[spFuncNow] := IfThen(Parameters.IsProxySQLAdmin, 'CURRENT_TIMESTAMP', 'NOW()'); FSQLSpecifities[spLockedTables] := ''; FSQLSpecifities[spDisableForeignKeyChecks] := 'SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0'; FSQLSpecifities[spEnableForeignKeyChecks] := 'SET FOREIGN_KEY_CHECKS=IFNULL(@OLD_FOREIGN_KEY_CHECKS, 1)'; end; ngMSSQL: begin FSQLSpecifities[spDatabaseDrop] := 'DROP DATABASE %s'; FSQLSpecifities[spEmptyTable] := 'DELETE FROM '; FSQLSpecifities[spRenameTable] := 'EXEC sp_rename %s, %s'; FSQLSpecifities[spRenameView] := FSQLSpecifities[spRenameTable]; FSQLSpecifities[spCurrentUserHost] := 'SELECT SYSTEM_USER'; FSQLSpecifities[spLikeCompare] := '%s LIKE %s'; FSQLSpecifities[spAddColumn] := 'ADD %s'; FSQLSpecifities[spChangeColumn] := 'ALTER COLUMN %s %s'; FSQLSpecifities[spSessionVariables] := 'SELECT '+QuoteIdent('comment')+', '+QuoteIdent('value')+' FROM '+QuoteIdent('master')+'.'+QuoteIdent('dbo')+'.'+QuoteIdent('syscurconfigs')+' ORDER BY '+QuoteIdent('comment'); FSQLSpecifities[spGlobalVariables] := FSQLSpecifities[spSessionVariables]; FSQLSpecifities[spISSchemaCol] := '%s_CATALOG'; FSQLSpecifities[spUSEQuery] := 'USE %s'; FSQLSpecifities[spKillQuery] := 'KILL %d'; FSQLSpecifities[spKillProcess] := 'KILL %d'; FSQLSpecifities[spFuncLength] := 'LEN'; FSQLSpecifities[spFuncCeil] := 'CEILING'; FSQLSpecifities[spFuncLeft] := 'LEFT(%s, %d)'; FSQLSpecifities[spFuncNow] := 'GETDATE()'; FSQLSpecifities[spLockedTables] := ''; FSQLSpecifities[spDisableForeignKeyChecks] := ''; FSQLSpecifities[spEnableForeignKeyChecks] := ''; end; ngPgSQL: begin FSQLSpecifities[spDatabaseDrop] := 'DROP SCHEMA %s'; FSQLSpecifities[spEmptyTable] := 'DELETE FROM '; FSQLSpecifities[spRenameTable] := 'ALTER TABLE %s RENAME TO %s'; FSQLSpecifities[spRenameView] := 'ALTER VIEW %s RENAME TO %s'; FSQLSpecifities[spCurrentUserHost] := 'SELECT CURRENT_USER'; FSQLSpecifities[spLikeCompare] := '%s ILIKE %s'; FSQLSpecifities[spAddColumn] := 'ADD %s'; FSQLSpecifities[spChangeColumn] := 'ALTER COLUMN %s %s'; FSQLSpecifities[spRenameColumn] := 'RENAME COLUMN %s TO %s'; FSQLSpecifities[spSessionVariables] := 'SHOW ALL'; FSQLSpecifities[spGlobalVariables] := FSQLSpecifities[spSessionVariables]; FSQLSpecifities[spISSchemaCol] := '%s_schema'; FSQLSpecifities[spUSEQuery] := 'SET search_path TO %s'; FSQLSpecifities[spKillQuery] := 'SELECT pg_cancel_backend(%d)'; FSQLSpecifities[spKillProcess] := 'SELECT pg_cancel_backend(%d)'; FSQLSpecifities[spFuncLength] := 'LENGTH'; FSQLSpecifities[spFuncCeil] := 'CEIL'; FSQLSpecifities[spFuncLeft] := 'SUBSTRING(%s, 1, %d)'; FSQLSpecifities[spFuncNow] := 'NOW()'; FSQLSpecifities[spLockedTables] := ''; FSQLSpecifities[spDisableForeignKeyChecks] := ''; FSQLSpecifities[spEnableForeignKeyChecks] := ''; end; ngSQLite: begin FSQLSpecifities[spDatabaseDrop] := 'DROP DATABASE %s'; FSQLSpecifities[spEmptyTable] := 'DELETE FROM '; FSQLSpecifities[spRenameTable] := 'ALTER TABLE %s RENAME TO %s'; FSQLSpecifities[spRenameView] := FSQLSpecifities[spRenameTable]; FSQLSpecifities[spCurrentUserHost] := ''; // unsupported FSQLSpecifities[spLikeCompare] := '%s LIKE %s'; FSQLSpecifities[spAddColumn] := 'ADD COLUMN %s'; FSQLSpecifities[spChangeColumn] := ''; // SQLite only supports renaming FSQLSpecifities[spRenameColumn] := 'RENAME COLUMN %s TO %s'; FSQLSpecifities[spSessionVariables] := 'SELECT null, null'; // Todo: combine "PRAGMA pragma_list" + "PRAGMA a; PRAGMY b; ..."? FSQLSpecifities[spGlobalVariables] := 'SHOW GLOBAL VARIABLES'; FSQLSpecifities[spISSchemaCol] := '%s_SCHEMA'; FSQLSpecifities[spUSEQuery] := ''; FSQLSpecifities[spKillQuery] := 'KILL %d'; FSQLSpecifities[spKillProcess] := 'KILL %d'; FSQLSpecifities[spFuncLength] := 'LENGTH'; FSQLSpecifities[spFuncCeil] := 'CEIL'; FSQLSpecifities[spFuncLeft] := 'SUBSTR(%s, 1, %d)'; FSQLSpecifities[spFuncNow] := 'DATETIME()'; FSQLSpecifities[spLockedTables] := ''; FSQLSpecifities[spDisableForeignKeyChecks] := ''; FSQLSpecifities[spEnableForeignKeyChecks] := ''; end; ngInterbase: begin FSQLSpecifities[spDatabaseDrop] := 'DROP DATABASE %s'; FSQLSpecifities[spEmptyTable] := 'TRUNCATE '; FSQLSpecifities[spRenameTable] := 'RENAME TABLE %s TO %s'; FSQLSpecifities[spRenameView] := FSQLSpecifities[spRenameTable]; if Self.Parameters.LibraryOrProvider = 'IB' then FSQLSpecifities[spCurrentUserHost] := 'select user from rdb$database' else FSQLSpecifities[spCurrentUserHost] := 'select current_user || ''@'' || mon$attachments.mon$remote_host from mon$attachments where mon$attachments.mon$attachment_id = current_connection'; FSQLSpecifities[spLikeCompare] := '%s LIKE %s'; FSQLSpecifities[spAddColumn] := 'ADD COLUMN %s'; FSQLSpecifities[spChangeColumn] := 'CHANGE COLUMN %s %s'; FSQLSpecifities[spRenameColumn] := ''; FSQLSpecifities[spSessionVariables] := 'SHOW VARIABLES'; FSQLSpecifities[spGlobalVariables] := 'SHOW GLOBAL VARIABLES'; FSQLSpecifities[spISSchemaCol] := '%s_SCHEMA'; FSQLSpecifities[spUSEQuery] := ''; FSQLSpecifities[spKillQuery] := 'KILL %d'; FSQLSpecifities[spKillProcess] := 'KILL %d'; FSQLSpecifities[spFuncLength] := 'LENGTH'; FSQLSpecifities[spFuncCeil] := 'CEIL'; FSQLSpecifities[spFuncLeft] := 'SUBSTR(%s, 1, %d)'; FSQLSpecifities[spFuncNow] := ' cast(''now'' as timestamp) from rdb$database'; FSQLSpecifities[spLockedTables] := ''; FSQLSpecifities[spDisableForeignKeyChecks] := ''; FSQLSpecifities[spEnableForeignKeyChecks] := ''; end; end; end; procedure TMySQLConnection.DoBeforeConnect; var LibraryPath: String; begin // Init libmysql before actually connecting. LibraryPath := ExtractFilePath(ParamStr(0)) + Parameters.LibraryOrProvider; Log(lcDebug, f_('Loading library file %s ...', [LibraryPath])); // Throws EDbError on any failure: FLib := TMySQLLib.Create(LibraryPath, Parameters.DefaultLibrary); Log(lcDebug, FLib.DllFile + ' v' + DecodeApiString(FLib.mysql_get_client_info) + ' loaded.'); inherited; end; procedure TPgConnection.DoBeforeConnect; var LibraryPath, msg: String; begin // Init lib before actually connecting. LibraryPath := ExtractFilePath(ParamStr(0)) + Parameters.LibraryOrProvider; Log(lcDebug, f_('Loading library file %s ...', [LibraryPath])); try FLib := TPostgreSQLLib.Create(LibraryPath, Parameters.DefaultLibrary); Log(lcDebug, FLib.DllFile + ' v' + IntToStr(FLib.PQlibVersion) + ' loaded.'); except on E:EDbError do begin // Try to explain what may cause this error msg := E.Message; if E.ErrorCode = TDbLib.LIB_PROC_ERROR then begin msg := msg + sLineBreak + sLineBreak + f_('Your %s is incompatible to %s, or your system is missing a dependent library.', [Parameters.LibraryOrProvider, APPNAME]); end; // In any case: msg := msg + sLineBreak + sLineBreak + f_('Installing %s might help. Please download from %s', ['VC Redistributable', 'https://support.microsoft.com/en-us/help/3179560/update-for-visual-c-2013-and-visual-c-redistributable-package'] ); raise EDbError.Create(msg, E.ErrorCode); end; end; inherited; end; procedure TSQLiteConnection.DoBeforeConnect; var LibraryPath: String; begin // Init lib before actually connecting. LibraryPath := ExtractFilePath(ParamStr(0)) + Parameters.LibraryOrProvider; Log(lcDebug, f_('Loading library file %s ...', [LibraryPath])); // Throws EDbError on any failure: FLib := TSQLiteLib.Create(LibraryPath, Parameters.DefaultLibrary); Log(lcDebug, FLib.DllFile + ' v' + ServerVersionUntouched + ' loaded.'); inherited; end; procedure TInterbaseConnection.DoBeforeConnect; begin // Todo inherited; end; procedure TDBConnection.DoAfterConnect; var SQLFunctionsFileOrder: String; begin AppSettings.SessionPath := FParameters.SessionPath; AppSettings.WriteString(asServerVersionFull, FServerVersionUntouched); FParameters.ServerVersion := FServerVersionUntouched; Log(lcInfo, f_('Connected. Thread-ID: %d', [ThreadId])); if Assigned(FOnConnected) then FOnConnected(Self, FDatabase); if FParameters.KeepAlive > 0 then begin FKeepAliveTimer.Interval := FParameters.KeepAlive * 1000; FKeepAliveTimer.OnTimer := KeepAliveTimerEvent; end; if FParameters.IsMariaDB then SQLFunctionsFileOrder := 'mariadb,mysql' else if FParameters.IsAnyMySQL then SQLFunctionsFileOrder := 'mysql' else if FParameters.IsRedshift then SQLFunctionsFileOrder := 'redshift,postgresql' else if FParameters.IsAnyPostgreSQL then SQLFunctionsFileOrder := 'postgresql' else if FParameters.IsAnyMSSQL then SQLFunctionsFileOrder := 'mssql' else if FParameters.IsAnySQLite then SQLFunctionsFileOrder := 'sqlite' else if FParameters.IsAnyInterbase then SQLFunctionsFileOrder := 'interbase' else SQLFunctionsFileOrder := ''; FSQLFunctions := TSQLFunctionList.Create(Self, SQLFunctionsFileOrder); end; procedure TMySQLConnection.DoAfterConnect; var TZI: TTimeZoneInformation; Minutes, Hours, i: Integer; Offset: String; ObjNames: TStringList; begin inherited; // Set timezone offset to UTC if (ServerVersionInt >= 40103) and Parameters.LocalTimeZone then begin Minutes := 0; case GetTimeZoneInformation(TZI) of TIME_ZONE_ID_STANDARD: Minutes := (TZI.Bias + TZI.StandardBias); TIME_ZONE_ID_DAYLIGHT: Minutes := (TZI.Bias + TZI.DaylightBias); TIME_ZONE_ID_UNKNOWN: Minutes := TZI.Bias; else RaiseLastOSError; end; Hours := Minutes div 60; Minutes := Minutes mod 60; if Hours < 0 then Offset := '+' else Offset := '-'; Offset := Offset + Format('%.2d:%.2d', [Abs(Hours), Abs(Minutes)]); Query('SET time_zone='+EscapeString(Offset)); end; // Support microseconds in some temporal datatypes of MariaDB 5.3+ and MySQL 5.6 if ((ServerVersionInt >= 50300) and Parameters.IsMariaDB) or ((ServerVersionInt >= 50604) and (not Parameters.IsMariaDB)) then begin for i:=Low(FDatatypes) to High(FDatatypes) do begin if FDatatypes[i].Index in [dbdtDatetime, dbdtDatetime2, dbdtTime, dbdtTimestamp] then FDatatypes[i].HasLength := True; end; end; if ServerVersionInt >= 50000 then begin FSQLSpecifities[spKillQuery] := 'KILL QUERY %d'; end; // List of IS tables try ObjNames := GetCol('SHOW TABLES FROM '+QuoteIdent(FInfSch)); FInformationSchemaObjects.CommaText := ObjNames.CommaText; ObjNames.Free; except // silently fail if IS does not exist, on super old servers end; if (ServerVersionInt >= 50124) and (not Parameters.IsProxySQLAdmin) then FSQLSpecifities[spLockedTables] := 'SHOW OPEN TABLES FROM %s WHERE '+QuoteIdent('in_use')+'!=0'; end; procedure TAdoDBConnection.DoAfterConnect; begin inherited; // See http://sqlserverbuilds.blogspot.de/ case ServerVersionInt of 0..899: begin FSQLSpecifities[spDatabaseTable] := QuoteIdent('master')+'..'+QuoteIdent('sysdatabases'); FSQLSpecifities[spDatabaseTableId] := QuoteIdent('dbid'); FSQLSpecifities[spDbObjectsTable] := '..'+QuoteIdent('sysobjects'); FSQLSpecifities[spDbObjectsCreateCol] := 'crdate'; FSQLSpecifities[spDbObjectsUpdateCol] := ''; FSQLSpecifities[spDbObjectsTypeCol] := 'xtype'; end; else begin FSQLSpecifities[spDatabaseTable] := QuoteIdent('sys')+'.'+QuoteIdent('databases'); FSQLSpecifities[spDatabaseTableId] := QuoteIdent('database_id'); FSQLSpecifities[spDbObjectsTable] := '.'+QuoteIdent('sys')+'.'+QuoteIdent('objects'); FSQLSpecifities[spDbObjectsCreateCol] := 'create_date'; FSQLSpecifities[spDbObjectsUpdateCol] := 'modify_date'; FSQLSpecifities[spDbObjectsTypeCol] := 'type'; end; end; // List of known IS tables FInformationSchemaObjects.CommaText := 'CHECK_CONSTRAINTS,'+ 'COLUMN_DOMAIN_USAGE,'+ 'COLUMN_PRIVILEGES,'+ 'COLUMNS,'+ 'CONSTRAINT_COLUMN_USAGE,'+ 'CONSTRAINT_TABLE_USAGE,'+ 'DOMAIN_CONSTRAINTS,'+ 'DOMAINS,'+ 'KEY_COLUMN_USAGE,'+ 'PARAMETERS,'+ 'REFERENTIAL_CONSTRAINTS,'+ 'ROUTINES,'+ 'ROUTINE_COLUMNS,'+ 'SCHEMATA,'+ 'TABLE_CONSTRAINTS,'+ 'TABLE_PRIVILEGES,'+ 'TABLES,'+ 'VIEW_COLUMN_USAGE,'+ 'VIEW_TABLE_USAGE,'+ 'VIEWS'; end; procedure TPgConnection.DoAfterConnect; var ObjNames: TStringList; begin inherited; // List of known IS tables ObjNames := GetCol('SELECT table_name FROM information_schema.tables WHERE table_schema='+EscapeString(FInfSch)); FInformationSchemaObjects.CommaText := ObjNames.CommaText; ObjNames.Free; end; function TMySQLConnection.Ping(Reconnect: Boolean): Boolean; var IsDead: Boolean; begin Log(lcDebug, 'Ping server ...'); IsDead := True; try IsDead := (FHandle=nil) or (FLib.mysql_ping(FHandle) <> 0); except // silence dumb exceptions from mysql_ping on E:Exception do Log(lcError, E.Message); end; if IsDead then begin // Be sure to release some stuff before reconnecting Active := False; if Reconnect then Active := True; end; Result := FActive; // Restart keep-alive timer FKeepAliveTimer.Enabled := False; FKeepAliveTimer.Enabled := True; end; function TAdoDBConnection.Ping(Reconnect: Boolean): Boolean; begin Log(lcDebug, 'Ping server ...'); if FActive then try FAdoHandle.Execute('SELECT 1'); except on E:EOleException do begin FLastError := E.Message; Log(lcError, E.Message); Active := False; if Reconnect then Active := True; end; end; Result := FActive; // Restart keep-alive timer FKeepAliveTimer.Enabled := False; FKeepAliveTimer.Enabled := True; end; function TPGConnection.Ping(Reconnect: Boolean): Boolean; var PingResult: PPGResult; IsBroken: Boolean; PingStatus: Integer; begin Log(lcDebug, 'Ping server ...'); if FActive then begin IsBroken := FHandle = nil; if not IsBroken then begin PingStatus := FLib.PQsendQuery(FHandle, PAnsiChar('')); IsBroken := PingStatus <> 1; PingResult := FLib.PQgetResult(FHandle); while PingResult <> nil do begin FLib.PQclear(PingResult); PingResult := FLib.PQgetResult(FHandle); end; end; if IsBroken then begin // Be sure to release some stuff before reconnecting Active := False; if Reconnect then Active := True; end; end; Result := FActive; // Restart keep-alive timer FKeepAliveTimer.Enabled := False; FKeepAliveTimer.Enabled := True; end; function TSQLiteConnection.Ping(Reconnect: Boolean): Boolean; begin Log(lcDebug, 'Ping server ...'); if FActive then try FLib.sqlite3_exec(FHandle, nil, 0, nil, nil); except on E:Exception do begin Log(lcError, E.Message); Active := False; if Reconnect then Active := True; end; end; Result := FActive; // Restart keep-alive timer FKeepAliveTimer.Enabled := False; FKeepAliveTimer.Enabled := True; end; function TInterbaseConnection.Ping(Reconnect: Boolean): Boolean; begin Log(lcDebug, 'Ping server ...'); if FActive then begin FFDHandle.Ping; end; Result := FActive; // Restart keep-alive timer FKeepAliveTimer.Enabled := False; FKeepAliveTimer.Enabled := True; end; procedure TDBConnection.KeepAliveTimerEvent(Sender: TObject); begin // Ping server in intervals, without automatically reconnecting if Active and (FLockedByThread = nil) then Ping(False); end; {** Executes a query } procedure TMySQLConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); var QueryStatus: Integer; NativeSQL: AnsiString; TimerStart: Cardinal; QueryResult: PMYSQL_RES; begin if (FLockedByThread <> nil) and (FLockedByThread.ThreadID <> GetCurrentThreadID) then begin Log(lcDebug, _('Waiting for running query to finish ...')); try FLockedByThread.WaitFor; except on E:EThread do; end; end; Ping(True); Log(LogCategory, SQL); FLastQuerySQL := SQL; if IsUnicode then NativeSQL := UTF8Encode(SQL) else NativeSQL := AnsiString(SQL); TimerStart := GetTickCount; SetLength(FLastRawResults, 0); FStatementNum := 1; QueryStatus := FLib.mysql_real_query(FHandle, PAnsiChar(NativeSQL), Length(NativeSQL)); FLastQueryDuration := GetTickCount - TimerStart; FLastQueryNetworkDuration := 0; if QueryStatus <> 0 then begin // Most errors will show up here, some others slightly later, after mysql_store_result() Log(lcError, GetLastErrorMsg); raise EDbError.Create(GetLastErrorMsg, GetLastErrorCode); end else begin // We must call mysql_store_result() + mysql_free_result() to unblock the connection // See: http://dev.mysql.com/doc/refman/5.0/en/mysql-store-result.html FRowsAffected := 0; FWarningCount := FLib.mysql_warning_count(FHandle); FRowsFound := 0; TimerStart := GetTickCount; QueryResult := FLib.mysql_store_result(FHandle); FLastQueryNetworkDuration := GetTickCount - TimerStart; if (QueryResult = nil) and (FLib.mysql_affected_rows(FHandle) = -1) then begin // Indicates a late error, e.g. triggered by mysql_store_result(), after selecting a stored // function with invalid SQL body. Also SHOW TABLE STATUS on older servers. // See http://dev.mysql.com/doc/refman/5.0/en/mysql-affected-rows.html // "An integer greater than zero indicates the number of rows affected or // retrieved. Zero indicates that no records were updated for an UPDATE statement, no rows // matched the WHERE clause in the query or that no query has yet been executed. -1 // indicates that the query returned an error or that, for a SELECT query, // mysql_affected_rows() was called prior to calling mysql_store_result()." Log(lcError, GetLastErrorMsg); raise EDbError.Create(GetLastErrorMsg); end; if QueryResult = nil then DetectUSEQuery(SQL); while QueryStatus=0 do begin if QueryResult <> nil then begin // Statement returned a result set Inc(FRowsFound, FLib.mysql_num_rows(QueryResult)); if DoStoreResult then begin SetLength(FLastRawResults, Length(FLastRawResults)+1); FLastRawResults[Length(FLastRawResults)-1] := QueryResult; end else begin FLib.mysql_free_result(QueryResult); end; end else begin // No result, but probably affected rows Inc(FRowsAffected, FLib.mysql_affected_rows(FHandle)); end; // more results? -1 = no, >0 = error, 0 = yes (keep looping) Inc(FStatementNum); TimerStart := GetTickCount; QueryStatus := FLib.mysql_next_result(FHandle); Inc(FLastQueryDuration, GetTickCount - TimerStart); if QueryStatus = 0 then QueryResult := FLib.mysql_store_result(FHandle) else if QueryStatus > 0 then begin // MySQL stops executing a multi-query when an error occurs. So do we here by raising an exception. SetLength(FLastRawResults, 0); Log(lcError, GetLastErrorMsg); raise EDbError.Create(GetLastErrorMsg); end; end; end; end; procedure TAdoDBConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); var TimerStart: Cardinal; VarRowsAffected: OleVariant; QueryResult, NextResult: _RecordSet; Affected: Int64; begin if (FLockedByThread <> nil) and (FLockedByThread.ThreadID <> GetCurrentThreadID) then begin Log(lcDebug, _('Waiting for running query to finish ...')); try FLockedByThread.WaitFor; except on E:EThread do; end; end; Ping(True); Log(LogCategory, SQL); FLastQuerySQL := SQL; TimerStart := GetTickCount; SetLength(FLastRawResults, 0); FRowsFound := 0; FRowsAffected := 0; try QueryResult := FAdoHandle.ConnectionObject.Execute(SQL, VarRowsAffected, 1); FLastQueryDuration := GetTickCount - TimerStart; FLastQueryNetworkDuration := 0; // Handle multiple results while(QueryResult <> nil) do begin Affected := VarRowsAffected; Affected := Max(Affected, 0); Inc(FRowsAffected, Affected); NextResult := QueryResult.NextRecordset(VarRowsAffected); if QueryResult.Fields.Count > 0 then begin Inc(FRowsFound, QueryResult.RecordCount); if DoStoreResult then begin SetLength(FLastRawResults, Length(FLastRawResults)+1); FLastRawResults[Length(FLastRawResults)-1] := QueryResult; end else QueryResult := nil; end else QueryResult := nil; QueryResult := NextResult; end; DetectUSEQuery(SQL); except on E:EOleException do begin FLastError := E.Message; Log(lcError, GetLastErrorMsg); raise EDbError.Create(GetLastErrorMsg); end; end; end; procedure TPGConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); var TimerStart: Cardinal; QueryResult: PPGresult; QueryStatus: Integer; NativeSQL: AnsiString; begin if (FLockedByThread <> nil) and (FLockedByThread.ThreadID <> GetCurrentThreadID) then begin Log(lcDebug, _('Waiting for running query to finish ...')); try FLockedByThread.WaitFor; except on E:EThread do; end; end; Ping(True); Log(LogCategory, SQL); FLastQuerySQL := SQL; if IsUnicode then NativeSQL := UTF8Encode(SQL) else NativeSQL := AnsiString(SQL); TimerStart := GetTickCount; SetLength(FLastRawResults, 0); FRowsFound := 0; FRowsAffected := 0; FWarningCount := 0; QueryStatus := FLib.PQsendQuery(FHandle, PAnsiChar(NativeSQL)); FLastQueryDuration := GetTickCount - TimerStart; FLastQueryNetworkDuration := 0; if QueryStatus <> 1 then begin Log(lcError, GetLastErrorMsg); raise EDbError.Create(GetLastErrorMsg); end else begin FRowsAffected := 0; FRowsFound := 0; TimerStart := GetTickCount; QueryResult := FLib.PQgetResult(FHandle); FLastQueryNetworkDuration := GetTickCount - TimerStart; DetectUSEQuery(SQL); while QueryResult <> nil do begin if FLib.PQnfields(QueryResult) > 0 then begin // Statement returned a result set Inc(FRowsFound, FLib.PQntuples(QueryResult)); if DoStoreResult then begin SetLength(FLastRawResults, Length(FLastRawResults)+1); FLastRawResults[Length(FLastRawResults)-1] := QueryResult; end else begin FLib.PQclear(QueryResult); end; end else begin Inc(FRowsAffected, StrToIntDef(String(FLib.PQcmdTuples(QueryResult)), 0)); end; if LastErrorMsg <> '' then begin SetLength(FLastRawResults, 0); Log(lcError, GetLastErrorMsg); // Clear remaining results, to avoid "another command is already running" while QueryResult <> nil do begin FLib.PQclear(QueryResult); QueryResult := FLib.PQgetResult(FHandle); end; raise EDbError.Create(GetLastErrorMsg); end; // more results? QueryResult := FLib.PQgetResult(FHandle); end; end; end; procedure TSQLiteConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); var TimerStart, PrepareFlags: Cardinal; Rows: TSQLiteGridRows; Row: TGridRow; Value: TGridValue; QueryResult: Psqlite3_stmt; QueryStatus: Integer; i, OldRowsAffected: Integer; CurrentSQL, NextSQL: PAnsiChar; StepResult: Integer; begin if (FLockedByThread <> nil) and (FLockedByThread.ThreadID <> GetCurrentThreadID) then begin Log(lcDebug, _('Waiting for running query to finish ...')); try FLockedByThread.WaitFor; except on E:EThread do; end; end; Ping(True); Log(LogCategory, SQL); FLastQuerySQL := SQL; CurrentSQL := PAnsiChar(UTF8Encode(SQL)); TimerStart := GetTickCount; SetLength(FLastRawResults, 0); FRowsFound := 0; FRowsAffected := 0; FWarningCount := 0; OldRowsAffected := FLib.sqlite3_total_changes(FHandle); // Temporary: substract these later from total num QueryResult := nil; NextSQL := nil; PrepareFlags := SQLITE_PREPARE_PERSISTENT; while True do begin QueryStatus := FLib.sqlite3_prepare_v3(FHandle, CurrentSQL, -1, PrepareFlags, QueryResult, NextSQL); FLastQueryDuration := GetTickCount - TimerStart; FLastQueryNetworkDuration := 0; if QueryStatus <> SQLITE_OK then begin Log(lcError, GetLastErrorMsg); raise EDbError.Create(GetLastErrorMsg); end; FRowsFound := 0; if DoStoreResult and (FLib.sqlite3_column_count(QueryResult) > 0) then begin Rows := TSQLiteGridRows.Create(Self); StepResult := FLib.sqlite3_step(QueryResult); while StepResult = SQLITE_ROW do begin Row := TGridRow.Create; for i:=0 to FLib.sqlite3_column_count(QueryResult)-1 do begin Value := TGridValue.Create; Value.OldText := DecodeAPIString(FLib.sqlite3_column_text(QueryResult, i)); Value.OldIsNull := FLib.sqlite3_column_text(QueryResult, i) = nil; Row.Add(Value); end; Rows.Add(Row); StepResult := FLib.sqlite3_step(QueryResult); end; Inc(FRowsFound, Rows.Count); Rows.Statement := QueryResult; SetLength(FLastRawResults, Length(FLastRawResults)+1); FLastRawResults[Length(FLastRawResults)-1] := Rows; end else begin // Make one step through this non-result, otherwise SQLite does not seem to execute this query StepResult := FLib.sqlite3_step(QueryResult); FLib.sqlite3_finalize(QueryResult); end; FRowsAffected := FLib.sqlite3_total_changes(FHandle) - OldRowsAffected; if not (StepResult in [SQLITE_OK, SQLITE_ROW, SQLITE_DONE, SQLITE_MISUSE]) then begin SetLength(FLastRawResults, 0); Log(lcError, GetLastErrorMsg); // Todo: Step through and clear remaining results? raise EDbError.Create(GetLastErrorMsg); end; DetectUSEQuery(SQL); CurrentSQL := NextSQL; if Trim(CurrentSQL) = '' then Break; end; FLastQueryNetworkDuration := GetTickCount - TimerStart; end; procedure TInterbaseConnection.Query(SQL: String; DoStoreResult: Boolean=False; LogCategory: TDBLogCategory=lcSQL); var TimerStart: Cardinal; FdQuery: TFDQuery; begin if (FLockedByThread <> nil) and (FLockedByThread.ThreadID <> GetCurrentThreadID) then begin Log(lcDebug, _('Waiting for running query to finish ...')); try FLockedByThread.WaitFor; except on E:EThread do; end; end; Ping(True); Log(LogCategory, SQL); FLastQuerySQL := SQL; TimerStart := GetTickCount; SetLength(FLastRawResults, 0); FRowsFound := 0; FRowsAffected := 0; FWarningCount := 0; FdQuery := TFDQuery.Create(Self); FdQuery.Connection := FFDHandle; // Todo: suppress mouse cursor updates try FdQuery.ResourceOptions.CmdExecTimeout := Parameters.QueryTimeout; if DoStoreResult then begin FdQuery.SQL.Text := SQL; if FdQuery.OpenOrExecute then begin FRowsFound := FdQuery.RecordCount; SetLength(FLastRawResults, Length(FLastRawResults)+1); FLastRawResults[Length(FLastRawResults)-1] := FdQuery; end; end else begin FdQuery.ExecSQL(SQL); FRowsAffected := FdQuery.RowsAffected; FdQuery.Free; end; FLastQueryDuration := GetTickCount - TimerStart; FLastQueryNetworkDuration := 0; except on E:EFDDBEngineException do begin SetLength(FLastRawResults, 0); Log(lcError, GetLastErrorMsg + ' :: ' + E.Message); raise EDbError.Create(GetLastErrorMsg); end; end; FLastQueryNetworkDuration := GetTickCount - TimerStart; end; function TDBConnection.GetLastResults: TDBQueryList; var r: TDBQuery; i: Integer; begin Result := TDBQueryList.Create(False); for i:=0 to ResultCount-1 do begin r := Parameters.CreateQuery(Self); r.SQL := FLastQuerySQL; r.Execute(False, i); Result.Add(r); end; end; function TAdoDBConnection.GetLastResults: TDBQueryList; var r: TDBQuery; i: Integer; Batch: TSQLBatch; begin Result := TDBQueryList.Create(False); Batch := TSQLBatch.Create; Batch.SQL := FLastQuerySQL; for i:=Low(FLastRawResults) to High(FLastRawResults) do begin r := Parameters.CreateQuery(Self); if Batch.Count > i then r.SQL := Batch[i].SQL else // See http://www.heidisql.com/forum.php?t=21036 r.SQL := Batch.SQL; r.Execute(False, i); Result.Add(r); end; Batch.Free; end; function TMySQLConnection.GetCreateCode(Obj: TDBObject): String; var ColIdx: Integer; begin if Obj.NodeType = lntView then begin // Use our own baked CREATE VIEW code Result := GetCreateViewCode(Obj.Database, Obj.Name); Exit; end; case Obj.NodeType of lntTable: ColIdx := 1; lntFunction, lntProcedure, lntTrigger: ColIdx := 2; lntEvent: ColIdx := 3; else raise EDbError.CreateFmt(_('Unhandled list node type in %s.%s'), [ClassName, 'GetCreateCode']); end; Result := GetVar('SHOW CREATE '+Obj.ObjType.ToUpperInvariant+' '+QuoteIdent(Obj.Database)+'.'+QuoteIdent(Obj.Name), ColIdx); end; function TSQLiteConnection.GetCreateCode(Obj: TDBObject): String; begin // PRAGMA table_info(customers): // cid name type notnull dflt_value pk // 0 CustomerId INTEGER 1 null 1 // 1 FirstName NVARCHAR(40) 1 null 0 case Obj.NodeType of lntTable: begin Result := GetVar('SELECT '+QuoteIdent('sql')+' FROM '+QuoteIdent(Obj.Database)+'.sqlite_master'+ ' WHERE '+QuoteIdent('type')+'='+EscapeString('table')+ ' AND name='+EscapeString(Obj.Name)); end; else begin // Let the generic method try to return code, which will most likely fail on SQLite Result := inherited; end; end; end; function TInterbaseConnection.GetCreateCode(Obj: TDBObject): String; begin // Todo end; function TMySQLConnection.GetCreateViewCode(Database, Name: String): String; var ViewIS: TDBQuery; Algorithm, CheckOption, SelectCode, Definer, SQLSecurity: String; AlternativeSelectCode: String; rx: TRegExpr; Obj: TDBObject; begin // Get CREATE VIEW code, which can throw privilege errors and errors due to // references to renamed or deleted columns try Result := GetVar('SHOW CREATE VIEW '+QuoteIdent(Database)+'.'+QuoteIdent(Name), 1); except on E:EDbError do begin ViewIS := GetResults('SELECT * FROM '+InfSch+'.VIEWS WHERE '+ 'TABLE_SCHEMA='+EscapeString(Database)+' AND TABLE_NAME='+EscapeString(Name)); Result := 'CREATE '; if ViewIS.Col('DEFINER') <> '' then Result := Result + 'DEFINER='+QuoteIdent(ViewIS.Col('DEFINER'), True, '@')+' '; Result := Result + 'VIEW '+QuoteIdent(Name)+' AS '+ViewIS.Col('VIEW_DEFINITION')+' '; if ViewIS.Col('CHECK_OPTION') <> 'NONE' then Result := Result + 'WITH '+Uppercase(ViewIS.Col('CHECK_OPTION'))+' CHECK OPTION'; end; end; try // Try to fetch original VIEW code from .frm file AlternativeSelectCode := GetVar('SELECT CAST(LOAD_FILE('+ 'CONCAT('+ 'IFNULL(@@GLOBAL.datadir, CONCAT(@@GLOBAL.basedir, '+EscapeString('data/')+')), '+ EscapeString(Database+'/'+Name+'.frm')+')'+ ') AS CHAR CHARACTER SET utf8)'); rx := TRegExpr.Create; rx.ModifierI := True; rx.ModifierG := False; rx.Expression := '\nsource\=(.+)\n\w+\='; if rx.Exec(AlternativeSelectCode) then begin // Put pieces of CREATE VIEW together Obj := FindObject(Database, Name); ParseViewStructure(Result, Obj, Algorithm, Definer, SQLSecurity, CheckOption, SelectCode); AlternativeSelectCode := UnescapeString(rx.Match[1]); Result := 'CREATE '; if Algorithm <> '' then Result := Result + 'ALGORITHM='+Uppercase(Algorithm)+' '; if Definer <> '' then Result := Result + 'DEFINER='+QuoteIdent(Definer, True, '@')+' '; if not SQLSecurity.IsEmpty then Result := Result + 'SQL SECURITY '+SQLSecurity+' '; Result := Result + 'VIEW '+Obj.QuotedName+' AS '+AlternativeSelectCode+' '; // WITH .. CHECK OPTION is already contained in the source end; rx.Free; except // Do not raise if that didn't work on E:EDbError do; end; end; function TDBConnection.GetCreateCode(Obj: TDBObject): String; var ProcDetails: TDBQuery; DataType: String; ArgNames, ArgTypes, Arguments: TStringList; Rows: TStringList; i: Integer; TableCols: TTableColumnList; TableCol: TTableColumn; TableKeys: TTableKeyList; TableKey: TTableKey; TableForeignKeys: TForeignKeyList; TableForeignKey: TForeignKey; TableCheckConstraints: TCheckConstraintList; TableCheckConstraint: TCheckConstraint; begin case Obj.NodeType of lntTable: begin Result := 'CREATE TABLE '+QuoteIdent(Obj.Name)+' ('; TableCols := Obj.GetTableColumns; for TableCol in TableCols do begin Result := Result + CRLF + #9 + TableCol.SQLCode + ','; end; TableCols.Free; TableKeys := Obj.GetTableKeys; for TableKey in TableKeys do begin Result := Result + CRLF + #9 + TableKey.SQLCode + ','; end; TableKeys.Free; TableForeignKeys := Obj.GetTableForeignKeys; for TableForeignKey in TableForeignKeys do begin Result := Result + CRLF + #9 + TableForeignKey.SQLCode(True) + ','; end; TableForeignKeys.Free; TableCheckConstraints := Obj.GetTableCheckConstraints; for TableCheckConstraint in TableCheckConstraints do begin Result := Result + CRLF + #9 + TableCheckConstraint.SQLCode + ','; end; TableCheckConstraints.Free; Delete(Result, Length(Result), 1); Result := Result + CRLF + ')'; end; lntView: begin case FParameters.NetTypeGroup of ngPgSQL: begin // Prefer pg_catalog tables. See http://www.heidisql.com/forum.php?t=16213#p16685 Result := 'CREATE VIEW ' + QuoteIdent(Obj.Name) + ' AS ' + GetVar('SELECT '+QuoteIdent('definition')+ ' FROM '+QuoteIdent('pg_views')+ ' WHERE '+QuoteIdent('viewname')+'='+EscapeString(Obj.Name)+ ' AND '+QuoteIdent('schemaname')+'='+EscapeString(Obj.Schema) ); end; ngMSSQL: begin // Overcome 4000 character limit in IS.VIEW_DEFINITION // See http://www.heidisql.com/forum.php?t=21097 Result := GetVar('SELECT '+QuoteIdent('MODS')+'.'+QuoteIdent('DEFINITION')+ ' FROM '+QuoteIdent('SYS')+'.'+QuoteIdent('OBJECTS')+' '+QuoteIdent('OBJ')+ ' JOIN '+QuoteIdent('SYS')+'.'+QuoteIdent('SQL_MODULES')+' AS '+QuoteIdent('MODS')+' ON '+QuoteIdent('OBJ')+'.'+QuoteIdent('OBJECT_ID')+'='+QuoteIdent('MODS')+'.'+QuoteIdent('OBJECT_ID')+ ' JOIN '+QuoteIdent('SYS')+'.'+QuoteIdent('SCHEMAS')+' AS '+QuoteIdent('SCHS')+' ON '+QuoteIdent('OBJ')+'.'+QuoteIdent('SCHEMA_ID')+'='+QuoteIdent('SCHS')+'.'+QuoteIdent('SCHEMA_ID')+ ' WHERE '+QuoteIdent('OBJ')+'.'+QuoteIdent('TYPE')+'='+EscapeString('V')+ ' AND '+QuoteIdent('SCHS')+'.'+QuoteIdent('NAME')+'='+EscapeString(Obj.Schema)+ ' AND '+QuoteIdent('OBJ')+'.'+QuoteIdent('NAME')+'='+EscapeString(Obj.Name) ); end; else begin if not Obj.FCreateCode.IsEmpty then begin // SQlite views go here Result := Obj.FCreateCode; end else begin Result := GetVar('SELECT VIEW_DEFINITION'+ ' FROM '+InfSch+'.VIEWS'+ ' WHERE TABLE_NAME='+EscapeString(Obj.Name)+ ' AND '+Obj.SchemaClauseIS('TABLE') ); end; end; end; end; lntFunction: begin case Parameters.NetTypeGroup of ngMSSQL: begin // Tested on MS SQL 8.0 and 11.0 // See http://www.heidisql.com/forum.php?t=12495 if not Obj.Schema.IsEmpty then Rows := GetCol('EXEC sp_helptext '+EscapeString(Obj.Schema+'.'+Obj.Name)) else Rows := GetCol('EXEC sp_helptext '+EscapeString(Obj.Database+'.'+Obj.Name)); // Do not use Rows.Text, as the rows already include a trailing linefeed Result := Implode('', Rows); Rows.Free; end; ngPgSQL: begin Result := 'CREATE FUNCTION '+QuoteIdent(Obj.Name); ProcDetails := GetResults('SELECT '+ QuoteIdent('p')+'.'+QuoteIdent('prosrc')+', '+ QuoteIdent('p')+'.'+QuoteIdent('proargnames')+', '+ QuoteIdent('p')+'.'+QuoteIdent('proargtypes')+', '+ QuoteIdent('p')+'.'+QuoteIdent('prorettype')+' '+ 'FROM '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_namespace')+' AS '+QuoteIdent('n')+' '+ 'JOIN '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_proc')+' AS '+QuoteIdent('p')+' ON '+QuoteIdent('p')+'.'+QuoteIdent('pronamespace')+' = '+QuoteIdent('n')+'.'+QuoteIdent('oid')+' '+ 'WHERE '+ QuoteIdent('n')+'.'+QuoteIdent('nspname')+'='+EscapeString(Obj.Database)+ 'AND '+QuoteIdent('p')+'.'+QuoteIdent('proname')+'='+EscapeString(Obj.Name)+ 'AND '+QuoteIdent('p')+'.'+QuoteIdent('proargtypes')+'='+EscapeString(Obj.ArgTypes) ); ArgNames := Explode(',', Copy(ProcDetails.Col('proargnames'), 2, Length(ProcDetails.Col('proargnames'))-2)); ArgTypes := Explode(' ', Copy(ProcDetails.Col('proargtypes'), 1, Length(ProcDetails.Col('proargtypes')))); Arguments := TStringList.Create; for i:=0 to ArgNames.Count-1 do begin if ArgTypes.Count > i then DataType := GetDatatypeByNativeType(MakeInt(ArgTypes[i]), ArgNames[i]).Name else DataType := ''; Arguments.Add(ArgNames[i] + ' ' + DataType); end; Result := Result + '(' + Implode(', ', Arguments) + ') '+ 'RETURNS '+GetDatatypeByNativeType(MakeInt(ProcDetails.Col('prorettype'))).Name+' '+ 'AS $$ '+ProcDetails.Col('prosrc')+' $$' // TODO: 'LANGUAGE SQL IMMUTABLE STRICT' ; end; else begin Result := GetVar('SELECT ROUTINE_DEFINITION'+ ' FROM '+InfSch+'.ROUTINES'+ ' WHERE ROUTINE_NAME='+EscapeString(Obj.Name)+ ' AND ROUTINE_TYPE='+EscapeString('FUNCTION')+ ' AND '+Obj.SchemaClauseIS('ROUTINE') ); end; end; end; lntProcedure: begin case Parameters.NetTypeGroup of ngMSSQL: begin // See comments above if not Obj.Schema.IsEmpty then Rows := GetCol('EXEC sp_helptext '+EscapeString(Obj.Schema+'.'+Obj.Name)) else Rows := GetCol('EXEC sp_helptext '+EscapeString(Obj.Database+'.'+Obj.Name)); Result := Implode('', Rows); Rows.Free; end; else begin Result := GetVar('SELECT ROUTINE_DEFINITION'+ ' FROM '+InfSch+'.ROUTINES'+ ' WHERE ROUTINE_NAME='+EscapeString(Obj.Name)+ ' AND ROUTINE_TYPE='+EscapeString('PROCEDURE')+ ' AND '+Obj.SchemaClauseIS('ROUTINE') ); end; end; end; end; end; procedure TDBConnection.PrefetchCreateCode(Objects: TDBObjectList); var Queries: TStringList; Obj: TDBObject; UseIt: Boolean; begin // Cache some queries used in GetCreateCode for mass operations. See TMainForm.SynCompletionProposalExecute Queries := TStringList.Create; for Obj in Objects do begin case Parameters.NetTypeGroup of ngMySQL: begin UseIt := Obj.NodeType <> lntView; // SHOW CREATE TRIGGER was introduced in MySQL 5.1.21 // See #111 if Obj.NodeType = lntTrigger then UseIt := UseIt and (ServerVersionInt >= 50121); if UseIt then Queries.Add('SHOW CREATE '+UpperCase(Obj.ObjType)+' '+QuoteIdent(Obj.Database)+'.'+QuoteIdent(Obj.Name)); end; ngMSSQL: begin if Obj.NodeType in [lntFunction, lntProcedure] then begin if not Obj.Schema.IsEmpty then Queries.Add('EXEC sp_helptext '+EscapeString(Obj.Schema+'.'+Obj.Name)) else Queries.Add('EXEC sp_helptext '+EscapeString(Obj.Database+'.'+Obj.Name)) end; end; else begin Log(lcDebug, 'No query logic for PrefetchCreateCode'); end; end; end; if Queries.Count > 0 then try PrefetchResults(Implode(';', Queries)); except on E:EDbError do; end; end; {** Set "Database" property and select that db if connected } procedure TDBConnection.SetDatabase(Value: String); var s: String; UseQuery: String; begin Log(lcDebug, 'SetDatabase('+Value+'), FDatabase: '+FDatabase); if Value <> FDatabase then begin if Value = '' then begin FDatabase := Value; if Assigned(FOnDatabaseChanged) then FOnDatabaseChanged(Self, Value); end else begin if FParameters.NetTypeGroup = ngPgSQL then begin s := EscapeString(Value); // Get schema with the same name as user name in search path // See https://www.heidisql.com/forum.php?t=34558 s := s + ', ' + EscapeString('$user'); // Always keep public schema in search path, so one can use procedures from it without prefixing // See http://www.heidisql.com/forum.php?t=18581#p18905 if Value <> 'public' then s := s + ', ' + EscapeString('public'); end else s := QuoteIdent(Value); UseQuery := GetSQLSpecifity(spUSEQuery); if not UseQuery.IsEmpty then begin Query(GetSQLSpecifity(spUSEQuery, [s]), False); end; FDatabase := DeQuoteIdent(Value); if Assigned(FOnDatabaseChanged) then FOnDatabaseChanged(Self, Value); end; // Save last used database in session, see #983 if not FParameters.SessionName.IsEmpty then begin AppSettings.SessionPath := FParameters.SessionPath; AppSettings.WriteString(asLastUsedDB, Value); end; // Some session variables are specific to a database, like collation_database, see #1030 FreeAndNil(FSessionVariables); if Assigned(FOnObjectnamesChanged) then FOnObjectnamesChanged(Self, FDatabase); end; end; procedure TDBConnection.DetectUSEQuery(SQL: String); var rx: TRegExpr; Quotes: String; NewDb: String; begin // Detect query for switching current working database or schema rx := TRegExpr.Create; rx.ModifierI := True; rx.Expression := '^'+GetSQLSpecifity(spUSEQuery); Quotes := QuoteRegExprMetaChars(FQuoteChars+''';'); rx.Expression := StringReplace(rx.Expression, ' ', '\s+', [rfReplaceAll]); rx.Expression := StringReplace(rx.Expression, '%s', '['+Quotes+']?([^'+Quotes+']+)['+Quotes+']*', [rfReplaceAll]); if rx.Exec(SQL) then begin NewDb := Trim(rx.Match[1]); NewDb := DeQuoteIdent(NewDb); if (not NewDb.IsEmpty) and (NewDb <> FDatabase) then begin FDatabase := NewDb; Log(lcDebug, f_('Database "%s" selected', [FDatabase])); if Assigned(FOnDatabaseChanged) then FOnDatabaseChanged(Self, Database); end; end; rx.Free; end; {** Return current thread id Supports 64bit process numbers on long running servers: https://dev.mysql.com/doc/refman/8.0/en/mysql-thread-id.html ... while ProxySQL does not support CONNECTION_ID() } function TMySQLConnection.GetThreadId: Int64; begin if FThreadId = 0 then begin Ping(False); if FActive then begin if Parameters.IsProxySQLAdmin then FThreadID := FLib.mysql_thread_id(FHandle) else FThreadID := StrToInt64Def(GetVar('SELECT CONNECTION_ID()'), 0); end; end; Result := FThreadID; end; function TAdoDBConnection.GetThreadId: Int64; begin if FThreadId = 0 then begin Ping(False); if FActive then FThreadID := StrToInt64Def(GetVar('SELECT @@SPID'), 0); end; Result := FThreadID; end; function TPGConnection.GetThreadId: Int64; begin if FThreadId = 0 then begin Ping(False); if FActive then FThreadID := FLib.PQbackendPID(FHandle); end; Result := FThreadID; end; function TSQLiteConnection.GetThreadId: Int64; begin if FThreadId = 0 then begin Ping(False); if FActive then // We return the application process id, as there is no connection pid in SQLite FThreadID := Windows.GetCurrentProcessId; end; Result := FThreadID; end; function TInterbaseConnection.GetThreadId: Int64; begin // Todo Result := 0; end; {** Return currently used character set } function TDBConnection.GetCharacterSet: String; begin Result := ''; end; function TMySQLConnection.GetCharacterSet: String; begin Result := DecodeAPIString(FLib.mysql_character_set_name(FHandle)); end; {** Switch character set } procedure TDBConnection.SetCharacterSet(CharsetName: String); begin // Nothing to do by default end; procedure TMySQLConnection.SetCharacterSet(CharsetName: String); var Return: Integer; begin FStatementNum := 0; Log(lcInfo, 'Changing character set from '+CharacterSet+' to '+CharsetName); Return := FLib.mysql_set_character_set(FHandle, PAnsiChar(Utf8Encode(CharsetName))); if Return <> 0 then raise EDbError.Create(LastErrorMsg) else FIsUnicode := CharsetName.StartsWith('utf', True); end; procedure TPGConnection.SetCharacterSet(CharsetName: String); begin // See issue #22 Query('SET CLIENT_ENCODING TO ' + EscapeString('UTF8')); end; function TMySQLConnection.GetLastErrorCode: Cardinal; begin Result := FLib.mysql_errno(FHandle); end; function TAdoDBConnection.GetLastErrorCode: Cardinal; begin // SELECT @@SPID throws errors without filling the error pool. See issue #2684. if FAdoHandle.Errors.Count > 0 then Result := FAdoHandle.Errors[FAdoHandle.Errors.Count-1].NativeError else Result := 0; end; function TPgConnection.GetLastErrorCode: Cardinal; begin Result := Cardinal(FLib.PQstatus(FHandle)); end; function TSQLiteConnection.GetLastErrorCode: Cardinal; begin Result := FLib.sqlite3_errcode(FHandle); end; function TInterbaseConnection.GetLastErrorCode: Cardinal; begin // Note: there seem to be negative codes Result := Abs(FLastErrorCode); end; procedure TInterbaseConnection.OnFdError(ASender: TObject; AInitiator: TObject; var AException: Exception); var oExc: EFDDBEngineException; begin if AException is EFDDBEngineException then begin oExc := EFDDBEngineException(AException); FLastErrorCode := oExc.ErrorCode; FLastError := oExc.Message; end; end; {** Return the last error nicely formatted } function TMySQLConnection.GetLastErrorMsg: String; var Msg, Additional: String; rx: TRegExpr; begin Result := ''; Additional := ''; Msg := DecodeAPIString(FLib.mysql_error(FHandle)); // Find "(errno: 123)" in message and add more meaningful message from perror.exe rx := TRegExpr.Create; rx.Expression := '.+\(errno\:\s+(\d+)\)'; if rx.Exec(Msg) then begin Additional := MySQLErrorCodes.Values[rx.Match[1]]; end; rx.Free; if Additional <> '' then begin Msg := Msg + sLineBreak + sLineBreak + Additional; end; case FStatementNum of 0: Result := Msg; 1: Result := f_(MsgSQLError, [LastErrorCode, Msg]); else Result := f_(MsgSQLErrorMultiStatements, [LastErrorCode, FStatementNum, Msg]); end; end; function TAdoDBConnection.GetLastErrorMsg: String; var Msg: String; rx: TRegExpr; E: Error; begin if FAdoHandle.Errors.Count > 0 then begin E := FAdoHandle.Errors[FAdoHandle.Errors.Count-1]; Msg := E.Description; // Remove stuff from driver in message "[DBNETLIB][ConnectionOpen (Connect()).]" rx := TRegExpr.Create; rx.Expression := '^\[DBNETLIB\]\[.*\](.+)$'; if rx.Exec(Msg) then Msg := rx.Match[1]; rx.Free; end else Msg := _('unknown'); if (FLastError <> '') and (Pos(FLastError, Msg) = 0) then Msg := FLastError + CRLF + Msg; Result := f_(MsgSQLError, [LastErrorCode, Msg]); end; function TPgConnection.GetLastErrorMsg: String; begin // Todo: use MsgSQLError formatting constant Result := DecodeAPIString(FLib.PQerrorMessage(FHandle)); Result := Trim(Result); end; function TSQLiteConnection.GetLastErrorMsg: String; begin Result := DecodeAPIString(FLib.sqlite3_errmsg(FHandle)); Result := f_(MsgSQLError, [LastErrorCode, Result]); end; function TInterbaseConnection.GetLastErrorMsg: String; begin Result := f_(MsgSQLError, [LastErrorCode, FLastError]); end; {** Get version string as normalized integer "5.1.12-beta-community-123" => 50112 } function TDBConnection.ServerVersionInt: Integer; var rx: TRegExpr; v1, v2: String; begin Result := 0; rx := TRegExpr.Create; case FParameters.NetTypeGroup of ngMySQL, ngPgSQL, ngSQLite, ngInterbase: begin rx.Expression := '(\d+)\.(\d+)(\.(\d+))?'; if rx.Exec(FServerVersionUntouched) then begin Result := StrToIntDef(rx.Match[1], 0) *10000 + StrToIntDef(rx.Match[2], 0) *100 + StrToIntDef(rx.Match[4], 0); end; end; ngMSSQL: begin // See http://support.microsoft.com/kb/321185 // "Microsoft SQL Server 7.00 - 7.00.1094 (Intel X86)" ==> 700 // "Microsoft SQL Server 2008 (RTM) - 10.0.1600.22 (Intel X86)" ==> 1000 // "Microsoft SQL Server 2008 R2 (RTM) - 10.50.1600.1 (Intel X86)" ==> 1050 rx.ModifierG := False; rx.Expression := '\s(\d+)\.(\d+)\D'; if rx.Exec(FServerVersionUntouched) then begin v1 := rx.Match[1]; v2 := rx.Match[2]; Result := StrToIntDef(v1, 0) *100 + StrToIntDef(v2, 0); end else begin rx.Expression := '(\d+)[,\.](\d+)[,\.](\d+)[,\.](\d+)'; if rx.Exec(FServerVersionUntouched) then begin Result := StrToIntDef(rx.Match[1], 0) *100 + StrToIntDef(rx.Match[2], 0); end; end; end; else begin raise EDbError.CreateFmt(_(MsgUnhandledNetType), [Integer(FParameters.NetType)]); end; end; rx.Free; end; function TDBConnection.ServerVersionStr: String; var v: String; major, minor, build: Integer; begin case FParameters.NetTypeGroup of ngMySQL, ngPgSQL, ngSQLite, ngInterbase: begin v := IntToStr(ServerVersionInt); major := StrToIntDef(Copy(v, 1, Length(v)-4), 0); minor := StrToIntDef(Copy(v, Length(v)-3, 2), 0); build := StrToIntDef(Copy(v, Length(v)-1, 2), 0); Result := IntToStr(major) + '.' + IntToStr(minor) + '.' + IntToStr(build); end; ngMSSQL: begin major := ServerVersionInt div 100; minor := ServerVersionInt mod (ServerVersionInt div 100); Result := IntToStr(major) + '.' + IntToStr(minor); end; else begin raise EDbError.CreateFmt(_(MsgUnhandledNetType), [Integer(FParameters.NetType)]); end; end; end; function TDBConnection.NdbClusterVersionInt: Integer; var rx: TRegExpr; begin // 5.6.17-ndb-7.3.5 Result := 0; rx := TRegExpr.Create; rx.Expression := '[\d+\.]+-ndb-(\d+)\.(\d+)\.(\d+)'; if rx.Exec(FServerVersionUntouched) then begin Result := StrToIntDef(rx.Match[1], 0) *10000 + StrToIntDef(rx.Match[2], 0) *100 + StrToIntDef(rx.Match[3], 0); end; rx.Free; end; function TDBConnection.GetAllDatabases: TStringList; var rx: TRegExpr; dbname: String; begin // Get user passed delimited list if not Assigned(FAllDatabases) then begin if FParameters.AllDatabasesStr <> '' then begin FAllDatabases := TStringList.Create; rx := TRegExpr.Create; rx.Expression := '[^;]+'; rx.ModifierG := True; if rx.Exec(FParameters.AllDatabasesStr) then while true do begin // Add if not a duplicate dbname := Trim(rx.Match[0]); if FAllDatabases.IndexOf(dbname) = -1 then FAllDatabases.Add(dbname); if not rx.ExecNext then break; end; rx.Free; ApplyIgnoreDatabasePattern(FAllDatabases); end; end; Result := FAllDatabases; end; function TMySQLConnection.GetAllDatabases: TStringList; begin Result := inherited; if not Assigned(Result) then begin try FAllDatabases := GetCol('SHOW DATABASES', IfThen(Parameters.IsProxySQLAdmin, 1, 0)); except on E:EDbError do try FAllDatabases := GetCol('SELECT '+QuoteIdent('SCHEMA_NAME')+' FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent('SCHEMATA')+' ORDER BY '+QuoteIdent('SCHEMA_NAME')); except on E:EDbError do begin FAllDatabases := TStringList.Create; Log(lcError, f_('Database names not available due to missing privileges for user %s.', [CurrentUserHostCombination])); end; end; end; Result := FAllDatabases; ApplyIgnoreDatabasePattern(FAllDatabases); end; end; function TAdoDBConnection.GetAllDatabases: TStringList; begin Result := inherited; if not Assigned(Result) then begin try FAllDatabases := GetCol('SELECT '+QuoteIdent('name')+' FROM '+GetSQLSpecifity(spDatabaseTable)+' ORDER BY '+QuoteIdent('name')); except on E:EDbError do FAllDatabases := TStringList.Create; end; ApplyIgnoreDatabasePattern(FAllDatabases); Result := FAllDatabases; end; end; function TPGConnection.GetAllDatabases: TStringList; var DbQuery: String; begin // In PostgreSQL, we display schemata, not databases. // The AllDatabasesStr is used to set the single database name if not Assigned(FAllDatabases) then begin try // Query is.schemata when using schemata, for databases use pg_database //FAllDatabases := GetCol('SELECT datname FROM pg_database WHERE datistemplate=FALSE'); DbQuery := 'SELECT '+QuoteIdent('nspname')+ ' FROM '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_namespace'); if Parameters.IsRedshift then begin DbQuery := DbQuery + ' WHERE '+QuoteIdent('nspowner')+' != 1'+ ' OR '+QuoteIdent('nspname')+' IN ('+EscapeString('pg_catalog')+', '+EscapeString('public')+', '+EscapeString(InfSch)+')'; end; DbQuery := DbQuery + ' ORDER BY '+QuoteIdent('nspname'); FAllDatabases := GetCol(DbQuery); except on E:EDbError do FAllDatabases := TStringList.Create; end; ApplyIgnoreDatabasePattern(FAllDatabases); end; Result := FAllDatabases; end; function TSQLiteConnection.GetAllDatabases: TStringList; var DbQuery: String; begin Result := inherited; if not Assigned(Result) then begin try DbQuery := 'SELECT * FROM pragma_database_list'; FAllDatabases := GetCol(DbQuery, 1); except on E:EDbError do FAllDatabases := TStringList.Create; end; ApplyIgnoreDatabasePattern(FAllDatabases); Result := FAllDatabases; end; end; function TInterbaseConnection.GetAllDatabases: TStringList; begin Result := inherited; if not Assigned(Result) then begin FAllDatabases := TStringList.Create; FFDHandle.GetCatalogNames('', FAllDatabases); ApplyIgnoreDatabasePattern(FAllDatabases); Result := FAllDatabases; end; end; function TDBConnection.RefreshAllDatabases: TStringList; begin FreeAndNil(FAllDatabases); Result := AllDatabases; end; procedure TDBConnection.ApplyIgnoreDatabasePattern(Dbs: TStringList); var i: Integer; begin if Parameters.IgnoreDatabasePattern.IsEmpty then Exit; try for i:=Dbs.Count-1 downto 0 do begin if ExecRegExpr(Parameters.IgnoreDatabasePattern, Dbs[i]) then Dbs.Delete(i); end; except on E:ERegExpr do Log(lcError, 'Error in ignore database pattern: ' + E.Message); end; end; function TDBConnection.GetResults(SQL: String): TDBQuery; var Query: TDBQuery; begin Result := nil; // Look up query result in cache if Assigned(FPrefetchResults) then begin for Query in FPrefetchResults do begin if Query.SQL = SQL then begin Result := Query; Log(lcDebug, 'Using cached result for query: '+StrEllipsis(SQL, 100)); Break; end; end; end; // Fire query if Result = nil then begin Result := Parameters.CreateQuery(Self); Result.SQL := SQL; try Result.Execute; except FreeAndNil(Result); Raise; end; end; end; procedure TDBConnection.PrefetchResults(SQL: String); var LastResults: TDBQueryList; Batch: TSQLBatch; i: Integer; begin Query(SQL, True); Batch := TSQLBatch.Create; Batch.SQL := SQL; FreeAndNil(FPrefetchResults); FPrefetchResults := TDBQueryList.Create(True); LastResults := GetLastResults; for i:=0 to LastResults.Count-1 do begin FPrefetchResults.Add(LastResults[i]); if Batch.Count > i then FPrefetchResults[i].SQL := Batch[i].SQL; end; Batch.Free; end; procedure TDBConnection.FreeResults(Results: TDBQuery); begin // Free query result if it is not in prefetch cache if (not Assigned(FPrefetchResults)) or (not FPrefetchResults.Contains(Results)) then FreeAndNil(Results); end; {** Call log event if assigned to object If running a thread, log to queue and let the main thread later do logging } procedure TDBConnection.Log(Category: TDBLogCategory; Msg: String); var LogMessage, FilePath: String; DbObj: TDBObject; LogFileStream: TStreamWriter; function IsDdlQuery: Boolean; begin Result := Msg.StartsWith('CREATE', True) or Msg.StartsWith('ALTER', True) or Msg.StartsWith('DROP', True) or Msg.StartsWith('TRUNCATE', True) or Msg.StartsWith('COMMENT', True) or Msg.StartsWith('RENAME', True) ; end; function IsDmlQuery: Boolean; begin Result := Msg.StartsWith('INSERT', True) or Msg.StartsWith('UPDATE', True) or Msg.StartsWith('DELETE', True) or Msg.StartsWith('UPSERT', True) ; end; begin // If in a thread, synchronize logging with the main thread. Logging within a thread // causes SynEdit to throw exceptions left and right. if (FLockedByThread <> nil) and (FLockedByThread.ThreadID = GetCurrentThreadID) then begin (FLockedByThread as TQueryThread).LogFromThread(Msg, Category); Exit; end; if Assigned(FOnLog) then begin LogMessage := Msg; if FLogPrefix <> '' then LogMessage := '['+FLogPrefix+'] ' + LogMessage; FOnLog(LogMessage, Category, Self); end; if Category in [lcSQL, lcUserFiredSQL, lcScript] then begin if (Parameters.LogFileDdl and IsDdlQuery) or (Parameters.LogFileDml and IsDmlQuery) then begin // Log DDL queries to migration file DbObj := TDBObject.Create(Self); DbObj.Database := IfThen(FDatabase.IsEmpty, 'nodb', FDatabase); FilePath := GetOutputFilename(Parameters.LogFilePath, DbObj); DbObj.Free; try ForceDirectories(ExtractFileDir(FilePath)); LogFileStream := TStreamWriter.Create(FilePath, True, UTF8NoBOMEncoding); LogFileStream.Write(Msg + ';' + sLineBreak); LogFileStream.Free; except on E:Exception do begin Parameters.LogFileDdl := False; Parameters.LogFileDml := False; Log(lcError, E.Message); Log(lcInfo, _('Logging disabled')); end; end; end; end; end; {** Escapes a string for usage in SQL queries - single-backslashes which represent normal parts of the text and not escape-sequences - characters which MySQL doesn't strictly care about, but which might confuse editors etc. - single and double quotes in a text string - joker-chars for LIKE-comparisons Finally, surround the text by single quotes. @param string Text to escape @param boolean Escape text so it can be used in a LIKE-comparison @return string } function TDBConnection.EscapeString(Text: String; ProcessJokerChars: Boolean=false; DoQuote: Boolean=True): String; var c1, c2, c3, c4, EscChar: Char; begin case FParameters.NetTypeGroup of ngMySQL: begin c1 := ''''; c2 := '\'; c3 := '%'; c4 := '_'; EscChar := '\'; if not ProcessJokerChars then begin // Do not escape joker-chars which are used in a LIKE-clause c4 := ''''; c3 := ''''; end; Result := escChars(Text, EscChar, c1, c2, c3, c4); // Remove characters that SynEdit chokes on, so that // the SQL file can be non-corruptedly loaded again. c1 := #13; c2 := #10; c3 := #0; c4 := #0; // TODO: SynEdit also chokes on Char($2028) and possibly Char($2029). Result := escChars(Result, EscChar, c1, c2, c3, c4); end; ngMSSQL, ngSQLite: begin c1 := ''''; c2 := ''''; c3 := ''''; c4 := ''''; EscChar := ''''; Result := escChars(Text, EscChar, c1, c2, c3, c4); // Escape joker chars % and _ in conjunction with a specified escape char after the WHERE clause. // See http://www.heidisql.com/forum.php?t=12747 if ProcessJokerChars then begin c1 := '%'; c2 := '_'; c4 := '_'; c3 := '_'; EscChar := '\'; Result := escChars(Result, EscChar, c1, c2, c3, c4); end; end; ngPgSQL: begin if ProcessJokerChars then begin c1 := '%'; c2 := '_'; c3 := '%'; c4 := '%'; EscChar := '\'; Result := escChars(Text, EscChar, c1, c2, c3, c4); end else begin Result := Text; end; // Escape single quote with a second single quote Result := escChars(Result, '''', '''', '''', '''', ''''); end; ngInterbase: begin c1 := ''''; c2 := ''''; c3 := ''''; c4 := ''''; EscChar := '\'; Result := escChars(Text, EscChar, c1, c2, c3, c4); end; end; if DoQuote then begin // Add surrounding single quotes Result := FStringQuoteChar + Result + FStringQuoteChar; end; end; function TDBConnection.EscapeString(Text: String; Datatype: TDBDatatype): String; var DoQuote: Boolean; const CategoriesNeedQuote = [dtcText, dtcBinary, dtcTemporal, dtcSpatial, dtcOther]; begin // Quote text based on the passed datatype DoQuote := Datatype.Category in CategoriesNeedQuote; case Datatype.Category of // Some special cases dtcBinary: if IsHex(Text) then DoQuote := False; dtcInteger, dtcReal: if not ExecRegExpr('^\d+(\.\d+)?$', Text) then DoQuote := True; end; Result := EscapeString(Text, False, DoQuote); end; {*** Attempt to do string replacement faster than StringReplace } function TDBConnection.escChars(const Text: String; EscChar, Char1, Char2, Char3, Char4: Char): String; const // Attempt to match whatever the CPU cache will hold. block: Cardinal = 65536; var bstart, bend, matches, i: Cardinal; // These could be bumped to uint64 if necessary. len, respos: Cardinal; next: Char; begin len := Length(Text); Result := ''; bend := 0; respos := 0; repeat bstart := bend + 1; bend := bstart + block - 1; if bend > len then bend := len; matches := 0; for i := bstart to bend do if (Text[i] = Char1) or (Text[i] = Char2) or (Text[i] = Char3) or (Text[i] = Char4) then Inc(matches); SetLength(Result, bend + 1 - bstart + matches + respos); for i := bstart to bend do begin next := Text[i]; if (next = Char1) or (next = Char2) or (next = Char3) or (next = Char4) then begin Inc(respos); Result[respos] := EscChar; // Special values for MySQL escape. if next = #13 then next := 'r'; if next = #10 then next := 'n'; if next = #0 then next := '0'; end; Inc(respos); Result[respos] := next; end; until bend = len; end; function TDBConnection.UnescapeString(Text: String): String; begin // Return text with MySQL special sequences turned back to normal characters Result := StringReplace(Text, '\\', '\', [rfReplaceAll]); Result := StringReplace(Result, '\0', #0, [rfReplaceAll]); Result := StringReplace(Result, '\b', #8, [rfReplaceAll]); Result := StringReplace(Result, '\t', #9, [rfReplaceAll]); Result := StringReplace(Result, '\n', #10, [rfReplaceAll]); Result := StringReplace(Result, '\r', #13, [rfReplaceAll]); Result := StringReplace(Result, '\Z', #26, [rfReplaceAll]); Result := StringReplace(Result, '''''', '''', [rfReplaceAll]); Result := StringReplace(Result, '\''', '''', [rfReplaceAll]); end; function TDBConnection.ExtractLiteral(var SQL: String; Prefix: String): String; var i, LitStart: Integer; InLiteral: Boolean; rx: TRegExpr; begin // Return comment from SQL and remove it from the original string // Single quotes are escaped by a second single quote Result := ''; rx := TRegExpr.Create; if Prefix.IsEmpty then rx.Expression := '^\s*''' else rx.Expression := '^\s*'+QuoteRegExprMetaChars(Prefix)+'\s+'''; rx.ModifierI := True; if rx.Exec(SQL) then begin LitStart := rx.MatchLen[0]+1; InLiteral := True; for i:=LitStart to Length(SQL) do begin if SQL[i] = '''' then InLiteral := not InLiteral else if not InLiteral then break; end; Result := Copy(SQL, LitStart, i-LitStart-1); Result := UnescapeString(Result); Delete(SQL, 1, i); end; rx.Free; end; {** Add backticks to identifier Todo: Support ANSI style } function TDBConnection.QuoteIdent(Identifier: String; AlwaysQuote: Boolean=True; Glue: Char=#0): String; var GluePos, i: Integer; begin Result := Identifier; GluePos := 0; if Glue <> #0 then begin GluePos := Pos(Glue, Result); if GluePos > 0 then Result := QuoteIdent(Copy(Result, 1, GluePos-1)) + Glue + QuoteIdent(Copy(Result, GluePos+1, MaxInt)); end; if GluePos = 0 then begin if not AlwaysQuote then begin if MySQLKeywords.IndexOf(Result) > -1 then AlwaysQuote := True else if SQLFunctions.Names.IndexOf(Result) > -1 then AlwaysQuote := True else for i:=1 to Length(Result) do begin if not CharInSet(Result[i], FIdentCharsNoQuote) then begin AlwaysQuote := True; break; end; end; end; if AlwaysQuote then begin Result := StringReplace(Result, FQuoteChar, FQuoteChar+FQuoteChar, [rfReplaceAll]); Result := FQuoteChar + Result + FQuoteChar; end; end; end; function TDBConnection.DeQuoteIdent(Identifier: String; Glue: Char=#0): String; var Quote: Char; begin Result := Identifier; if (Length(Identifier)>0) and (Result[1] = FQuoteChar) and (Result[Length(Identifier)] = FQuoteChar) then Result := Copy(Result, 2, Length(Result)-2); if Glue <> #0 then Result := StringReplace(Result, FQuoteChar+Glue+FQuoteChar, Glue, [rfReplaceAll]); Result := StringReplace(Result, FQuoteChar+FQuoteChar, FQuoteChar, [rfReplaceAll]); // Remove all probable quote characters, to fix various problems for Quote in FQuoteChars do begin Result := StringReplace(Result, Quote, '', [rfReplaceAll]); end; end; function TDBConnection.QuotedDbAndTableName(DB, Obj: String): String; var o: TDBObject; begin // Call TDBObject.QuotedDbAndTableName for db and table string. // Return fully qualified db and tablename, quoted, and including schema if required o := FindObject(DB, Obj); if o <> nil then Result := o.QuotedDbAndTableName() else begin // Fallback for target tables which do not yet exist. For example in copytable dialog. Result := QuoteIdent(DB) + '.'; if Parameters.IsAnyMSSQL then Result := Result + '.'; Result := Result + QuoteIdent(Obj); end; end; function TDBConnection.FindObject(DB, Obj: String): TDBObject; var Objects: TDBObjectList; o: TDBObject; begin // Find TDBObject by db and table string Objects := GetDBObjects(DB); Result := nil; for o in Objects do begin if o.Name = Obj then begin Result := o; Break; end; end; if not Assigned(Result) then begin Log(lcDebug, Format('Could not find object "%s" in database "%s"', [Obj, DB])); end; end; function TDBConnection.GetCol(SQL: String; Column: Integer=0): TStringList; var Results: TDBQuery; begin Results := GetResults(SQL); Result := TStringList.Create; if Results.RecordCount > 0 then while not Results.Eof do begin Result.Add(Results.Col(Column)); Results.Next; end; FreeResults(Results); end; {** Get single cell value via SQL query, identified by column number } function TDBConnection.GetVar(SQL: String; Column: Integer=0): String; var Results: TDBQuery; begin Results := GetResults(SQL); if Results.RecordCount > 0 then Result := Results.Col(Column) else Result := ''; FreeResults(Results); end; {** Get single cell value via SQL query, identified by column name } function TDBConnection.GetVar(SQL: String; Column: String): String; var Results: TDBQuery; begin Results := GetResults(SQL); if Results.RecordCount > 0 then Result := Results.Col(Column) else Result := ''; FreeResults(Results); end; function TDBConnection.GetTableEngines: TStringList; begin if not Assigned(FTableEngines) then FTableEngines := TStringList.Create; Result := FTableEngines; end; function TMySQLConnection.GetTableEngines: TStringList; var Results: TDBQuery; engineName, engineSupport: String; rx: TRegExpr; begin // After a disconnect Ping triggers the cached engines to be reset Log(lcDebug, 'Fetching list of table engines ...'); Ping(True); if not Assigned(FTableEngines) then begin FTableEngines := TStringList.Create; try Results := GetResults('SHOW ENGINES'); while not Results.Eof do begin engineName := Results.Col('Engine'); engineSupport := LowerCase(Results.Col('Support')); // Add to dropdown if supported if (engineSupport = 'yes') or (engineSupport = 'default') then FTableEngines.Add(engineName); // Check if this is the default engine if engineSupport = 'default' then FTableEngineDefault := engineName; Results.Next; end; Results.Free; except // Ignore errors on old servers and try a fallback: // Manually fetch available engine types by analysing have_* options // This is for servers below 4.1 or when the SHOW ENGINES statement has // failed for some other reason Results := GetSessionVariables(False); // Add default engines which will not show in a have_* variable: FTableEngines.CommaText := 'MyISAM,MRG_MyISAM,HEAP'; FTableEngineDefault := 'MyISAM'; rx := TRegExpr.Create; rx.ModifierI := True; rx.Expression := '^have_(ARCHIVE|BDB|BLACKHOLE|CSV|EXAMPLE|FEDERATED|INNODB|ISAM)(_engine)?$'; while not Results.Eof do begin if rx.Exec(Results.Col(0)) and (LowerCase(Results.Col(1)) = 'yes') then FTableEngines.Add(UpperCase(rx.Match[1])); Results.Next; end; rx.Free; end; end; Result := FTableEngines; end; function TDBConnection.GetCollationTable: TDBQuery; begin Log(lcDebug, 'Fetching list of collations ...'); Ping(True); Result := FCollationTable; end; function TMySQLConnection.GetCollationTable: TDBQuery; begin inherited; if (not Assigned(FCollationTable)) and (ServerVersionInt >= 40100) then FCollationTable := GetResults('SHOW COLLATION'); if Assigned(FCollationTable) then FCollationTable.First; Result := FCollationTable; end; function TAdoDBConnection.GetCollationTable: TDBQuery; begin inherited; if (not Assigned(FCollationTable)) then FCollationTable := GetResults('SELECT '+EscapeString('')+' AS '+QuoteIdent('Collation')+', '+ EscapeString('')+' AS '+QuoteIdent('Charset')+', 0 AS '+QuoteIdent('Id')+', '+ EscapeString('')+' AS '+QuoteIdent('Default')+', '+EscapeString('')+' AS '+QuoteIdent('Compiled')+', '+ '1 AS '+QuoteIdent('Sortlen')); if Assigned(FCollationTable) then FCollationTable.First; Result := FCollationTable; end; function TInterbaseConnection.GetCollationTable: TDBQuery; begin inherited; if not Assigned(FCollationTable) then begin FCollationTable := GetResults('SELECT RDB$COLLATION_NAME AS '+QuoteIdent('Collation')+', RDB$COLLATION_ID AS '+QuoteIdent('Id')+', RDB$CHARACTER_SET_ID FROM RDB$COLLATIONS'); end; if Assigned(FCollationTable) then FCollationTable.First; Result := FCollationTable; end; function TDBConnection.GetCollationList: TStringList; var c: TDBQuery; begin c := CollationTable; Result := TStringList.Create; if Assigned(c) then while not c.Eof do begin Result.Add(c.Col('Collation')); c.Next; end; end; function TSQLiteConnection.GetCollationList: TStringList; begin // See https://www.sqlite.org/datatype3.html#collation_sequence_examples Result := TStringList.Create; Result.CommaText := 'nocase,binary,rtrim'; end; function TDBConnection.GetCharsetTable: TDBQuery; begin Log(lcDebug, 'Fetching charset list ...'); Ping(True); Result := nil; end; function TMySQLConnection.GetCharsetTable: TDBQuery; begin inherited; if (not Assigned(FCharsetTable)) and (ServerVersionInt >= 40100) then FCharsetTable := GetResults('SHOW CHARSET'); Result := FCharsetTable; end; function TAdoDBConnection.GetCharsetTable: TDBQuery; begin inherited; if not Assigned(FCharsetTable) then FCharsetTable := GetResults('SELECT '+QuoteIdent('name')+' AS '+QuoteIdent('Charset')+', '+QuoteIdent('description')+' AS '+QuoteIdent('Description')+ ' FROM '+QuotedDbAndTableName('master', 'syscharsets') ); Result := FCharsetTable; end; function TPgConnection.GetCharsetTable: TDBQuery; begin inherited; if not Assigned(FCharsetTable) then FCharsetTable := GetResults('SELECT PG_ENCODING_TO_CHAR('+QuoteIdent('encid')+') AS '+QuoteIdent('Charset')+', '+EscapeString('')+' AS '+QuoteIdent('Description')+' FROM ('+ 'SELECT '+QuoteIdent('conforencoding')+' AS '+QuoteIdent('encid')+' FROM '+QuoteIdent('pg_conversion')+', '+QuoteIdent('pg_database')+' '+ 'WHERE '+QuoteIdent('contoencoding')+'='+QuoteIdent('encoding')+' AND '+QuoteIdent('datname')+'=CURRENT_DATABASE()) AS '+QuoteIdent('e') ); Result := FCharsetTable; end; function TSQLiteConnection.GetCharsetTable; begin inherited; if not Assigned(FCharsetTable) then begin //FCharsetTable := // Todo! end; Result := FCharsetTable; end; function TInterbaseConnection.GetCharsetTable: TDBQuery; begin inherited; if not Assigned(FCharsetTable) then FCharsetTable := GetResults('SELECT RDB$CHARACTER_SET_NAME AS '+QuoteIdent('Charset')+', RDB$CHARACTER_SET_NAME AS '+QuoteIdent('Description')+' FROM RDB$CHARACTER_SETS'); Result := FCharsetTable; end; function TDBConnection.GetCharsetList: TStringList; var c: TDBQuery; begin c := CharsetTable; Result := TStringList.Create; if Assigned(c) then begin c.First; while not c.Eof do begin Result.Add(c.Col('Charset') + ': ' + c.Col('Description')); c.Next; end; Result.Sort; end; end; function TDBConnection.GetSessionVariables(Refresh: Boolean): TDBQuery; begin // Return server variables if (not Assigned(FSessionVariables)) or Refresh then begin if Assigned(FSessionVariables) then FreeAndNil(FSessionVariables); FSessionVariables := GetResults(GetSQLSpecifity(spSessionVariables)); end; FSessionVariables.First; Result := FSessionVariables; end; function TDBConnection.GetSessionVariable(VarName: String; DefaultValue: String=''; Refresh: Boolean=False): String; var Vars: TDBQuery; VarExists: Boolean; begin // Return the value of a specific server variable Vars := GetSessionVariables(Refresh); Result := DefaultValue; VarExists := False; while not Vars.Eof do begin if Vars.Col(0) = VarName then begin Result := Vars.Col(1); VarExists := True; Break; end; Vars.Next; end; if not VarExists then begin Log(lcDebug, 'Variable "'+VarName+'" does not exist'); end; end; function TDBConnection.MaxAllowedPacket: Int64; begin // Default Result := SIZE_MB; end; function TMySQLConnection.MaxAllowedPacket: Int64; begin Result := MakeInt(GetSessionVariable('max_allowed_packet')); if Result < SIZE_KB*10 then begin Result := SIZE_MB; Log(lcError, f_('The server did not return a non-zero value for the %s variable. Assuming %s now.', ['max_allowed_packet', FormatByteNumber(Result)])); end; end; function TDBConnection.GetLockedTableCount(db: String): Integer; var sql: String; LockedTables: TStringList; begin // Find tables which are currently locked. // Used to prevent waiting time in GetDBObjects. sql := GetSQLSpecifity(spLockedTables); Result := 0; if not sql.IsEmpty then try LockedTables := GetCol(Format(sql, [QuoteIdent(db,False)])); Result := LockedTables.Count; LockedTables.Free; except // Suppress errors, due to not working on all servers: https://www.heidisql.com/forum.php?t=34984 on E:EDbError do; end; end; function TDBConnection.IdentifierEquals(Ident1, Ident2: String): Boolean; begin // Compare only name of identifier, in the case fashion the server tells us case FCaseSensitivity of 0: Result := Ident1 = Ident2; else Result := CompareText(Ident1, Ident2) = 0; end; end; function TDBConnection.IsTextDefault(Value: String; Tp: TDBDatatype): Boolean; begin // Helper for GetTableColumns if FParameters.IsMariaDB then begin // Only MariaDB 10.2.27+ wraps default text in single quotes // see https://mariadb.com/kb/en/information-schema-columns-table/ Result := (ServerVersionInt >= 100207) and Value.StartsWith(''''); // Prior to 10.2.1, only CURRENT_TIMESTAMP allowed // see https://mariadb.com/kb/en/create-table/#default-column-option Result := Result or ((ServerVersionInt < 100201) and (not Value.StartsWith('CURRENT_TIMESTAMP', True))); // Inexact fallback detection, wrong if MariaDB allows "0+1" as expression at some point Result := Result or Value.IsEmpty or IsInt(Value[1]); end else if FParameters.IsAnyMySQL then begin // Only MySQL case with expression in default value is as follows: if (Tp.Category = dtcTemporal) and Value.StartsWith('CURRENT_TIMESTAMP', True) then begin Result := False; end else begin Result := True; end; end else begin // MS SQL, PG and SQLite: Result := True; end; end; function TDBConnection.GetTableColumns(Table: TDBObject): TTableColumnList; var TableIdx: Integer; ColQuery: TDBQuery; Col: TTableColumn; dt, DefText, ExtraText, MaxLen: String; begin // Generic: query table columns from IS.COLUMNS Log(lcDebug, 'Getting fresh columns for '+Table.QuotedDbAndTableName); Result := TTableColumnList.Create(True); TableIdx := InformationSchemaObjects.IndexOf('columns'); if TableIdx = -1 then begin // No is.columns table available Exit; end; ColQuery := GetResults('SELECT * FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent(InformationSchemaObjects[TableIdx])+ ' WHERE '+Table.SchemaClauseIS('TABLE')+' AND TABLE_NAME='+EscapeString(Table.Name)+ ' ORDER BY ORDINAL_POSITION'); while not ColQuery.Eof do begin Col := TTableColumn.Create(Self); Result.Add(Col); Col.Name := ColQuery.Col('COLUMN_NAME'); Col.OldName := Col.Name; // PG/MySQL use different fields: dt := IfThen(ColQuery.ColExists('COLUMN_TYPE'), 'COLUMN_TYPE', 'DATA_TYPE'); Col.ParseDatatype(ColQuery.Col(dt)); // PG/MSSQL don't include length in data type if Col.LengthSet.IsEmpty and Col.DataType.HasLength then begin MaxLen := ''; case Col.DataType.Category of dtcText, dtcBinary: begin if not ColQuery.IsNull('CHARACTER_MAXIMUM_LENGTH') then begin MaxLen := ColQuery.Col('CHARACTER_MAXIMUM_LENGTH'); if MaxLen = '-1' then MaxLen := 'max'; end; end; dtcInteger: begin if not ColQuery.IsNull('NUMERIC_PRECISION') then begin MaxLen := ColQuery.Col('NUMERIC_PRECISION'); end; end; dtcReal: begin // See #953 if (not ColQuery.IsNull('NUMERIC_PRECISION')) and (not ColQuery.IsNull('NUMERIC_SCALE')) then begin MaxLen := ColQuery.Col('NUMERIC_PRECISION') + ',' + StrToIntDef(ColQuery.Col('NUMERIC_SCALE'), 0).ToString; end; end; dtcTemporal: begin if not ColQuery.IsNull('DATETIME_PRECISION') then begin MaxLen := ColQuery.Col('DATETIME_PRECISION'); // Remove meaningless length of "0" if StrToIntDef(MaxLen, -1) < 1 then MaxLen := ''; end; end; end; if (not MaxLen.IsEmpty) and (MaxLen <> Col.DataType.DefaultSize.ToString) then Col.LengthSet := MaxLen; end; Col.Charset := ColQuery.Col('CHARACTER_SET_NAME'); Col.Collation := ColQuery.Col('COLLATION_NAME'); // MSSQL has no expression Col.GenerationExpression := ColQuery.Col('GENERATION_EXPRESSION', True); // PG has no extra: ExtraText := ColQuery.Col('EXTRA', True); Col.Virtuality := RegExprGetMatch('\b(\w+)\s+generated\b', ExtraText.ToLowerInvariant, 1); Col.AllowNull := ColQuery.Col('IS_NULLABLE').ToLowerInvariant = 'yes'; DefText := ColQuery.Col('COLUMN_DEFAULT'); Col.OnUpdateType := cdtNothing; if ExecRegExpr('\bauto_increment\b', ExtraText.ToLowerInvariant) then begin Col.DefaultType := cdtAutoInc; Col.DefaultText := 'AUTO_INCREMENT'; end else if DefText.ToLowerInvariant = 'null' then begin Col.DefaultType := cdtNull; end else if ColQuery.IsNull('COLUMN_DEFAULT') then begin if Col.AllowNull then Col.DefaultType := cdtNull else Col.DefaultType := cdtNothing; end else if IsTextDefault(DefText, Col.DataType) then begin Col.DefaultType := cdtText; Col.DefaultText := IfThen(DefText.StartsWith(''''), ExtractLiteral(DefText, ''), DefText); end else begin Col.DefaultType := cdtExpression; Col.DefaultText := DefText; end; Col.OnUpdateText := RegExprGetMatch('\bon update (.*)$', ExtraText, 1, False, True); if not Col.OnUpdateText.IsEmpty then begin Col.OnUpdateType := cdtExpression; end; // PG has no column_comment: Col.Comment := ColQuery.Col('COLUMN_COMMENT', True); ColQuery.Next; end; ColQuery.Free; end; function TMySQLConnection.GetTableColumns(Table: TDBObject): TTableColumnList; var TableIdx: Integer; ColQuery: TDBQuery; Col: TTableColumn; DefText, ExtraText: String; begin TableIdx := InformationSchemaObjects.IndexOf('columns'); if TableIdx > -1 then begin Result := inherited; Exit; end; // !!Fallback!! for old MySQL pre-5.0 servers and ProxySQL Result := TTableColumnList.Create(True); if Parameters.IsProxySQLAdmin then begin // ProxySQL has no IS.COLUMNS Result := TTableColumnList.Create(True); ColQuery := GetResults('SELECT * FROM pragma_table_info('+EscapeString(Table.Name)+')'); while not ColQuery.Eof do begin Col := TTableColumn.Create(Self); Result.Add(Col); Col.Name := ColQuery.Col('name'); Col.OldName := Col.Name; Col.ParseDatatype(ColQuery.Col('type')); Col.AllowNull := ColQuery.Col('notnull') <> '1'; Col.DefaultType := cdtNothing; Col.DefaultText := ''; Col.OnUpdateType := cdtNothing; Col.OnUpdateText := ''; ColQuery.Next; end; ColQuery.Free; end else begin // MySQL pre-5.0 has no IS.COLUMNS table ColQuery := GetResults('SHOW FULL COLUMNS FROM '+QuoteIdent(Table.Database)+'.'+QuoteIdent(Table.Name)); while not ColQuery.Eof do begin Col := TTableColumn.Create(Self); Result.Add(Col); Col.Name := ColQuery.Col(0); Col.OldName := Col.Name; Col.ParseDatatype(ColQuery.Col('Type')); Col.Collation := ColQuery.Col('Collation', True); if Col.Collation.ToLowerInvariant = 'null' then Col.Collation := ''; Col.AllowNull := ColQuery.Col('Null').ToLowerInvariant = 'yes'; DefText := ColQuery.Col('Default'); ExtraText := ColQuery.Col('Extra'); Col.OnUpdateType := cdtNothing; if ExecRegExpr('^auto_increment$', ExtraText.ToLowerInvariant) then begin Col.DefaultType := cdtAutoInc; Col.DefaultText := 'AUTO_INCREMENT'; end else if ColQuery.IsNull('Default') then begin Col.DefaultType := cdtNothing; end else if IsTextDefault(DefText, Col.DataType) then begin Col.DefaultType := cdtText; Col.DefaultText := IfThen(DefText.StartsWith(''''), ExtractLiteral(DefText, ''), DefText); end else begin Col.DefaultType := cdtExpression; Col.DefaultText := DefText; end; Col.OnUpdateText := RegExprGetMatch('^on update (.*)$', ExtraText, 1); if not Col.OnUpdateText.IsEmpty then begin Col.OnUpdateType := cdtExpression; end; Col.Comment := ColQuery.Col('Comment', True); ColQuery.Next; end; ColQuery.Free; end; end; function TAdoDBConnection.GetTableColumns(Table: TDBObject): TTableColumnList; var Comments: TDBQuery; TableCol: TTableColumn; begin // Parent method is sufficient for most things Result := inherited; // Remove surrounding parentheses from default value. See #721 for TableCol in Result do begin if not TableCol.DefaultText.IsEmpty then TableCol.DefaultText := RegExprGetMatch('^\((.*)\)$', TableCol.DefaultText, 1); end; // Column comments in MSSQL. See http://www.heidisql.com/forum.php?t=19576 try Comments := GetResults('SELECT c.name AS '+QuoteIdent('column')+', prop.value AS '+QuoteIdent('comment')+' '+ 'FROM sys.extended_properties AS prop '+ 'INNER JOIN sys.all_objects o ON prop.major_id = o.object_id '+ 'INNER JOIN sys.schemas s ON o.schema_id = s.schema_id '+ 'INNER JOIN sys.columns AS c ON prop.major_id = c.object_id AND prop.minor_id = c.column_id '+ 'WHERE '+ ' prop.name='+EscapeString('MS_Description')+ ' AND s.name='+EscapeString(Table.Schema)+ ' AND o.name='+EscapeString(Table.Name) ); while not Comments.Eof do begin for TableCol in Result do begin if TableCol.Name = Comments.Col('column') then begin TableCol.Comment := Comments.Col('comment'); Break; end; end; Comments.Next; end; except // Fails on old servers on E:EDbError do; end; end; function TPgConnection.GetTableColumns(Table: TDBObject): TTableColumnList; var Comments: TDBQuery; TableCol: TTableColumn; begin Result := inherited; // Column comments in Postgre. See issue #859 // Todo: add current schema to WHERE clause? Comments := GetResults('SELECT a.attname AS column, des.description AS comment'+ ' FROM pg_attribute AS a, pg_description AS des, pg_class AS pgc'+ ' WHERE'+ ' pgc.oid = a.attrelid'+ ' AND des.objoid = pgc.oid'+ ' AND pg_table_is_visible(pgc.oid)'+ ' AND pgc.relname = '+EscapeString(Table.Name)+ ' AND a.attnum = des.objsubid' ); while not Comments.Eof do begin for TableCol in Result do begin if TableCol.Name = Comments.Col('column') then begin TableCol.Comment := Comments.Col('comment'); Break; end; end; Comments.Next; end; end; function TSQLiteConnection.GetTableColumns(Table: TDBObject): TTableColumnList; var ColQuery: TDBQuery; Col: TTableColumn; begin // SQLite has no IS.COLUMNS // Todo: include database name // Todo: default values Result := TTableColumnList.Create(True); ColQuery := GetResults('SELECT * FROM '+QuoteIdent(Table.Database)+'.pragma_table_info('+EscapeString(Table.Name)+')'); while not ColQuery.Eof do begin Col := TTableColumn.Create(Self); Result.Add(Col); Col.Name := ColQuery.Col('name'); Col.OldName := Col.Name; Col.ParseDatatype(ColQuery.Col('type')); Col.AllowNull := ColQuery.Col('notnull') <> '1'; Col.DefaultType := cdtNothing; Col.DefaultText := ''; Col.OnUpdateType := cdtNothing; Col.OnUpdateText := ''; ColQuery.Next; end; ColQuery.Free; end; function TInterbaseConnection.GetTableColumns(Table: TDBObject): TTableColumnList; var ColQuery: TDBQuery; Col: TTableColumn; begin // Todo Result := TTableColumnList.Create(True); ColQuery := GetResults('SELECT r.RDB$FIELD_NAME AS field_name,'+ ' r.RDB$DESCRIPTION AS field_description,'+ ' r.RDB$DEFAULT_VALUE AS field_default_value,'+ ' r.RDB$NULL_FLAG AS null_flag,'+ ' f.RDB$FIELD_LENGTH AS field_length,'+ ' f.RDB$FIELD_PRECISION AS field_precision,'+ ' f.RDB$FIELD_SCALE AS field_scale,'+ ' f.RDB$FIELD_TYPE AS field_type,'+ ' f.RDB$FIELD_SUB_TYPE AS field_subtype,'+ ' coll.RDB$COLLATION_NAME AS field_collation,'+ ' cset.RDB$CHARACTER_SET_NAME AS field_charset'+ ' FROM RDB$RELATION_FIELDS r'+ ' LEFT JOIN RDB$FIELDS f ON r.RDB$FIELD_SOURCE = f.RDB$FIELD_NAME'+ ' LEFT JOIN RDB$CHARACTER_SETS cset ON f.RDB$CHARACTER_SET_ID = cset.RDB$CHARACTER_SET_ID'+ ' LEFT JOIN RDB$COLLATIONS coll ON f.RDB$COLLATION_ID = coll.RDB$COLLATION_ID'+ ' AND F.RDB$CHARACTER_SET_ID = COLL.RDB$CHARACTER_SET_ID'+ ' WHERE r.RDB$RELATION_NAME='+EscapeString(Table.Name)+ ' ORDER BY r.RDB$FIELD_POSITION'); while not ColQuery.Eof do begin Col := TTableColumn.Create(Self); Result.Add(Col); Col.Name := ColQuery.Col('FIELD_NAME'); Col.OldName := Col.Name; //Col.ParseDatatype(ColQuery.Col('type')); Col.DataType := GetDatatypeByNativeType(MakeInt(ColQuery.Col('FIELD_TYPE'))); Col.AllowNull := ColQuery.IsNull('NULL_FLAG'); Col.DefaultType := cdtNothing; Col.DefaultText := ''; Col.OnUpdateType := cdtNothing; Col.OnUpdateText := ''; ColQuery.Next; end; ColQuery.Free; end; function TDBConnection.GetTableKeys(Table: TDBObject): TTableKeyList; var ColTableIdx, ConTableIdx: Integer; KeyQuery: TDBQuery; NewKey: TTableKey; begin // Generic: query table keys from IS.KEY_COLUMN_USAGE Result := TTableKeyList.Create(True); ColTableIdx := InformationSchemaObjects.IndexOf('KEY_COLUMN_USAGE'); ConTableIdx := InformationSchemaObjects.IndexOf('TABLE_CONSTRAINTS'); KeyQuery := GetResults('SELECT * FROM '+ QuoteIdent(InfSch)+'.'+QuoteIdent(InformationSchemaObjects[ColTableIdx])+' AS col'+ ', '+QuoteIdent(InfSch)+'.'+QuoteIdent(InformationSchemaObjects[ConTableIdx])+' AS con'+ ' WHERE col.TABLE_SCHEMA='+EscapeString(IfThen(Parameters.IsAnyMSSQL, Table.Schema, Table.Database))+ ' AND col.TABLE_NAME='+EscapeString(Table.Name)+ ' AND col.TABLE_SCHEMA=con.TABLE_SCHEMA'+ ' AND col.TABLE_NAME=con.TABLE_NAME'+ ' AND col.CONSTRAINT_NAME=con.CONSTRAINT_NAME' ); NewKey := nil; while not KeyQuery.Eof do begin if (not KeyQuery.ColExists('REFERENCED_TABLE_NAME')) or KeyQuery.Col('REFERENCED_TABLE_NAME').IsEmpty then begin if (not Assigned(NewKey)) or (NewKey.Name <> KeyQuery.Col('CONSTRAINT_NAME')) then begin NewKey := TTableKey.Create(Self); Result.Add(NewKey); NewKey.Name := KeyQuery.Col('CONSTRAINT_NAME'); NewKey.OldName := NewKey.Name; if KeyQuery.Col('CONSTRAINT_TYPE').StartsWith(TTableKey.PRIMARY, True) then NewKey.IndexType := TTableKey.PRIMARY else NewKey.IndexType := KeyQuery.Col('CONSTRAINT_TYPE'); NewKey.OldIndexType := NewKey.IndexType; end; NewKey.Columns.Add(KeyQuery.Col('COLUMN_NAME')); NewKey.SubParts.Add(''); end; KeyQuery.Next; end; KeyQuery.Free; end; function TMySQLConnection.GetTableKeys(Table: TDBObject): TTableKeyList; var KeyQuery, ColQuery: TDBQuery; NewKey: TTableKey; begin Result := TTableKeyList.Create(True); if Parameters.IsProxySQLAdmin then begin ColQuery := GetResults('SELECT * '+ 'FROM pragma_table_info('+EscapeString(Table.Name)+') '+ 'WHERE pk!=0 ORDER BY pk'); NewKey := nil; while not ColQuery.Eof do begin if not Assigned(NewKey) then begin NewKey := TTableKey.Create(Self); Result.Add(NewKey); NewKey.Name := TTableKey.PRIMARY; NewKey.OldName := NewKey.Name; NewKey.IndexType := TTableKey.PRIMARY; NewKey.OldIndexType := NewKey.IndexType; end; NewKey.Columns.Add(ColQuery.Col('name')); NewKey.SubParts.Add(''); ColQuery.Next; end; ColQuery.Free; KeyQuery := GetResults('SELECT * '+ 'FROM pragma_index_list('+EscapeString(Table.Name)+') '+ 'WHERE origin!='+EscapeString('pk')); while not KeyQuery.Eof do begin NewKey := TTableKey.Create(Self); Result.Add(NewKey); NewKey.Name := KeyQuery.Col('name'); NewKey.OldName := NewKey.Name; NewKey.IndexType := IfThen(KeyQuery.Col('unique')='0', TTableKey.KEY, TTableKey.UNIQUE); NewKey.OldIndexType := NewKey.IndexType; ColQuery := GetResults('SELECT * '+ 'FROM pragma_index_info('+EscapeString(NewKey.Name)+')'); while not ColQuery.Eof do begin NewKey.Columns.Add(ColQuery.Col('name')); NewKey.SubParts.Add(''); ColQuery.Next; end; ColQuery.Free; KeyQuery.Next; end; KeyQuery.Free; end else begin KeyQuery := GetResults('SHOW INDEXES FROM '+QuoteIdent(Table.Name)+' FROM '+QuoteIdent(Table.Database)); NewKey := nil; while not KeyQuery.Eof do begin if (not Assigned(NewKey)) or (NewKey.Name <> KeyQuery.Col('Key_name')) then begin NewKey := TTableKey.Create(Self); Result.Add(NewKey); NewKey.Name := KeyQuery.Col('Key_name'); NewKey.OldName := NewKey.Name; if CompareText(NewKey.Name, TTableKey.PRIMARY) = 0 then NewKey.IndexType := TTableKey.PRIMARY else if KeyQuery.Col('Non_unique') = '0' then NewKey.IndexType := TTableKey.UNIQUE else if CompareText(KeyQuery.Col('Index_type'), TTableKey.FULLTEXT) = 0 then NewKey.IndexType := TTableKey.FULLTEXT else if CompareText(KeyQuery.Col('Index_type'), TTableKey.SPATIAL) = 0 then NewKey.IndexType := TTableKey.SPATIAL else NewKey.IndexType := TTableKey.KEY; NewKey.OldIndexType := NewKey.IndexType; if ExecRegExpr('(BTREE|HASH)', KeyQuery.Col('Index_type')) then NewKey.Algorithm := KeyQuery.Col('Index_type'); NewKey.Comment := KeyQuery.Col('Index_comment', True); end; NewKey.Columns.Add(KeyQuery.Col('Column_name')); if NewKey.IndexType = TTableKey.SPATIAL then NewKey.SubParts.Add('') // Prevent "Incorrect prefix key" else NewKey.SubParts.Add(KeyQuery.Col('Sub_part')); KeyQuery.Next; end; KeyQuery.Free; end; end; function TPGConnection.GetTableKeys(Table: TDBObject): TTableKeyList; var KeyQuery: TDBQuery; NewKey: TTableKey; begin Result := TTableKeyList.Create(True); // For PostgreSQL there seem to be privilege problems in IS. // See http://www.heidisql.com/forum.php?t=16213 if ServerVersionInt >= 90000 then begin KeyQuery := GetResults('WITH ndx_list AS ('+ ' SELECT pg_index.indexrelid, pg_class.oid'+ ' FROM pg_index, pg_class'+ ' WHERE pg_class.relname = '+EscapeString(Table.Name)+ ' AND pg_class.oid = pg_index.indrelid'+ ' ),'+ ' ndx_cols AS ('+ ' SELECT pg_class.relname, UNNEST(i.indkey) AS col_ndx,'+ ' CASE i.indisprimary WHEN true THEN '+EscapeString(TTableKey.PRIMARY)+' ELSE CASE i.indisunique WHEN true THEN '+EscapeString(TTableKey.UNIQUE)+' ELSE '+EscapeString(TTableKey.KEY)+' END END AS CONSTRAINT_TYPE,'+ ' pg_class.oid'+ ' FROM pg_class'+ ' JOIN pg_index i ON (pg_class.oid = i.indexrelid)'+ ' JOIN ndx_list ON (pg_class.oid = ndx_list.indexrelid)'+ ' WHERE pg_table_is_visible(pg_class.oid)'+ ' )'+ 'SELECT ndx_cols.relname AS CONSTRAINT_NAME, ndx_cols.CONSTRAINT_TYPE, a.attname AS COLUMN_NAME '+ 'FROM pg_attribute a '+ 'JOIN ndx_cols ON (a.attnum = ndx_cols.col_ndx) '+ 'JOIN ndx_list ON (ndx_list.oid = a.attrelid AND ndx_list.indexrelid = ndx_cols.oid)' ); end else begin KeyQuery := GetResults('SELECT '+QuoteIdent('c')+'.'+QuoteIdent('conname')+' AS '+QuoteIdent('CONSTRAINT_NAME')+', '+ 'CASE '+QuoteIdent('c')+'.'+QuoteIdent('contype')+' '+ 'WHEN '+EscapeString('c')+' THEN '+EscapeString('CHECK')+' '+ 'WHEN '+EscapeString('f')+' THEN '+EscapeString('FOREIGN KEY')+' '+ 'WHEN '+EscapeString('p')+' THEN '+EscapeString('PRIMARY KEY')+' '+ 'WHEN '+EscapeString('u')+' THEN '+EscapeString('UNIQUE')+' '+ 'END AS '+QuoteIdent('CONSTRAINT_TYPE')+', '+ QuoteIdent('a')+'.'+QuoteIdent('attname')+' AS '+QuoteIdent('COLUMN_NAME')+' '+ 'FROM '+QuoteIdent('pg_constraint')+' AS '+QuoteIdent('c')+' '+ 'LEFT JOIN '+QuoteIdent('pg_class')+' '+QuoteIdent('t')+' ON '+QuoteIdent('c')+'.'+QuoteIdent('conrelid')+'='+QuoteIdent('t')+'.'+QuoteIdent('oid')+' '+ 'LEFT JOIN '+QuoteIdent('pg_attribute')+' '+QuoteIdent('a')+' ON '+QuoteIdent('t')+'.'+QuoteIdent('oid')+'='+QuoteIdent('a')+'.'+QuoteIdent('attrelid')+' '+ 'LEFT JOIN '+QuoteIdent('pg_namespace')+' '+QuoteIdent('n')+' ON '+QuoteIdent('t')+'.'+QuoteIdent('relnamespace')+'='+QuoteIdent('n')+'.'+QuoteIdent('oid')+' '+ 'WHERE c.contype IN ('+EscapeString('p')+', '+EscapeString('u')+') '+ 'AND '+QuoteIdent('a')+'.'+QuoteIdent('attnum')+'=ANY('+QuoteIdent('c')+'.'+QuoteIdent('conkey')+') '+ 'AND '+QuoteIdent('n')+'.'+QuoteIdent('nspname')+'='+EscapeString(Table.Schema)+' '+ 'AND '+QuoteIdent('t')+'.'+QuoteIdent('relname')+'='+EscapeString(Table.Name)+' '+ 'ORDER BY '+QuoteIdent('a')+'.'+QuoteIdent('attnum') ); end; NewKey := nil; while not KeyQuery.Eof do begin if (not Assigned(NewKey)) or (NewKey.Name <> KeyQuery.Col('CONSTRAINT_NAME')) then begin NewKey := TTableKey.Create(Self); Result.Add(NewKey); NewKey.Name := KeyQuery.Col('CONSTRAINT_NAME'); NewKey.OldName := NewKey.Name; NewKey.IndexType := KeyQuery.Col('CONSTRAINT_TYPE'); if NewKey.IndexType.ToLowerInvariant.EndsWith(' key') then Delete(NewKey.IndexType, Length(NewKey.IndexType)-4, 4); NewKey.OldIndexType := NewKey.IndexType; end; NewKey.Columns.Add(KeyQuery.Col('COLUMN_NAME')); NewKey.SubParts.Add(''); KeyQuery.Next; end; KeyQuery.Free; end; function TSQLiteConnection.GetTableKeys(Table: TDBObject): TTableKeyList; var ColQuery, KeyQuery: TDBQuery; NewKey: TTableKey; begin Result := TTableKeyList.Create(True); ColQuery := GetResults('SELECT * '+ 'FROM '+QuoteIdent(Table.Database)+'.pragma_table_info('+EscapeString(Table.Name)+') '+ 'WHERE pk!=0 ORDER BY pk'); NewKey := nil; while not ColQuery.Eof do begin if not Assigned(NewKey) then begin NewKey := TTableKey.Create(Self); Result.Add(NewKey); NewKey.Name := TTableKey.PRIMARY; NewKey.OldName := NewKey.Name; NewKey.IndexType := TTableKey.PRIMARY; NewKey.OldIndexType := NewKey.IndexType; end; NewKey.Columns.Add(ColQuery.Col('name')); NewKey.SubParts.Add(''); ColQuery.Next; end; ColQuery.Free; KeyQuery := GetResults('SELECT * '+ 'FROM '+QuoteIdent(Table.Database)+'.pragma_index_list('+EscapeString(Table.Name)+') '+ 'WHERE origin!='+EscapeString('pk')); while not KeyQuery.Eof do begin NewKey := TTableKey.Create(Self); Result.Add(NewKey); NewKey.Name := KeyQuery.Col('name'); NewKey.OldName := NewKey.Name; NewKey.IndexType := IfThen(KeyQuery.Col('unique')='0', TTableKey.KEY, TTableKey.UNIQUE); NewKey.OldIndexType := NewKey.IndexType; ColQuery := GetResults('SELECT * '+ 'FROM '+QuoteIdent(Table.Database)+'.pragma_index_info('+EscapeString(NewKey.Name)+')'); while not ColQuery.Eof do begin NewKey.Columns.Add(ColQuery.Col('name')); NewKey.SubParts.Add(''); ColQuery.Next; end; ColQuery.Free; KeyQuery.Next; end; KeyQuery.Free; end; function TInterbaseConnection.GetTableKeys(Table: TDBObject): TTableKeyList; begin Result := TTableKeyList.Create(True); end; function TDBConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList; var ForeignQuery, ColQuery: TDBQuery; ForeignKey: TForeignKey; begin // Generic: query table foreign keys from IS.? Result := TForeignKeyList.Create(True); if FForeignKeyQueriesFailed then begin Log(lcDebug, 'Avoid foreign key retrieval with queries which failed before'); Exit; end; try // Combine two IS tables by hand, not by JOIN, as this is too slow. See #852 ForeignQuery := GetResults('SELECT *'+ ' FROM '+InfSch+'.REFERENTIAL_CONSTRAINTS'+ ' WHERE'+ ' CONSTRAINT_SCHEMA='+EscapeString(Table.Database)+ ' AND TABLE_NAME='+EscapeString(Table.Name)+ ' AND REFERENCED_TABLE_NAME IS NOT NULL' ); ColQuery := GetResults('SELECT *'+ ' FROM '+InfSch+'.KEY_COLUMN_USAGE'+ ' WHERE'+ ' TABLE_SCHEMA='+EscapeString(Table.Database)+ ' AND TABLE_NAME='+EscapeString(Table.Name)+ ' AND REFERENCED_TABLE_NAME IS NOT NULL' ); try while not ForeignQuery.Eof do begin ForeignKey := TForeignKey.Create(Self); Result.Add(ForeignKey); ForeignKey.KeyName := ForeignQuery.Col('CONSTRAINT_NAME'); ForeignKey.OldKeyName := ForeignKey.KeyName; ForeignKey.Db := Table.Database; ForeignKey.ReferenceDb := ForeignQuery.Col('UNIQUE_CONSTRAINT_SCHEMA'); ForeignKey.ReferenceTable := ForeignQuery.Col('UNIQUE_CONSTRAINT_SCHEMA') + '.' + ForeignQuery.Col('REFERENCED_TABLE_NAME'); ForeignKey.OnUpdate := ForeignQuery.Col('UPDATE_RULE'); ForeignKey.OnDelete := ForeignQuery.Col('DELETE_RULE'); while not ColQuery.Eof do begin if ColQuery.Col('CONSTRAINT_NAME') = ForeignQuery.Col('CONSTRAINT_NAME') then begin ForeignKey.Columns.Add(ColQuery.Col('COLUMN_NAME')); ForeignKey.ForeignColumns.Add(ColQuery.Col('REFERENCED_COLUMN_NAME')); end; ColQuery.Next; end; ColQuery.First; ForeignQuery.Next; end; ForeignQuery.Free; ColQuery.Free; except // Don't silence errors here: on E:EDbError do Log(lcError, E.Message); end; except // Silently ignore non existent IS tables and/or columns // And remember to not fire such queries again here on E:EDbError do begin FForeignKeyQueriesFailed := True; end; end; end; function TAdoDbConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList; var ForeignQuery: TDBQuery; ForeignKey: TForeignKey; begin // MS SQL: see #150 Result := TForeignKeyList.Create(True); ForeignQuery := GetResults('SELECT'+ ' f.name AS foreign_key_name,'+ ' COL_NAME(fc.parent_object_id, fc.parent_column_id) AS constraint_column_name,'+ ' OBJECT_NAME (f.referenced_object_id) AS referenced_object,'+ ' COL_NAME(fc.referenced_object_id, fc.referenced_column_id) AS referenced_column_name,'+ ' update_referential_action_desc,'+ ' delete_referential_action_desc'+ ' FROM sys.foreign_keys AS f'+ ' INNER JOIN sys.foreign_key_columns AS fc'+ ' ON f.object_id = fc.constraint_object_id'+ ' WHERE f.parent_object_id = OBJECT_ID('+EscapeString(Table.Name)+')' ); ForeignKey := nil; while not ForeignQuery.Eof do begin if (not Assigned(ForeignKey)) or (ForeignKey.KeyName <> ForeignQuery.Col('foreign_key_name')) then begin ForeignKey := TForeignKey.Create(Self); Result.Add(ForeignKey); ForeignKey.KeyName := ForeignQuery.Col('foreign_key_name'); ForeignKey.OldKeyName := ForeignKey.KeyName; ForeignKey.ReferenceTable := ForeignQuery.Col('referenced_object'); ForeignKey.OnUpdate := ForeignQuery.Col('update_referential_action_desc'); ForeignKey.OnDelete := ForeignQuery.Col('delete_referential_action_desc'); end; ForeignKey.Columns.Add(ForeignQuery.Col('constraint_column_name')); ForeignKey.ForeignColumns.Add(ForeignQuery.Col('referenced_column_name')); ForeignQuery.Next; end; ForeignQuery.Free; end; function TPgConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList; var ForeignQuery: TDBQuery; ForeignKey: TForeignKey; begin // see #158 Result := TForeignKeyList.Create(True); try ForeignQuery := GetResults('SELECT'+ ' refc.constraint_name,'+ ' refc.update_rule,'+ ' refc.delete_rule,'+ ' kcu.table_name,'+ ' STRING_AGG(distinct kcu.column_name, '','') AS columns,'+ ' ccu.table_schema AS ref_schema,'+ ' ccu.table_name AS ref_table,'+ ' STRING_AGG(distinct ccu.column_name, '','') AS ref_columns,'+ ' STRING_AGG(distinct kcu.ordinal_position::text, '','') AS ord_position'+ ' FROM'+ ' '+InfSch+'.referential_constraints AS refc,'+ ' '+InfSch+'.key_column_usage AS kcu,'+ ' '+InfSch+'.constraint_column_usage AS ccu'+ ' WHERE'+ ' refc.constraint_schema = '+EscapeString(Table.Schema)+ ' AND refc.constraint_name = kcu.constraint_name'+ ' AND refc.constraint_schema = kcu.table_schema'+ ' AND ccu.constraint_name = refc.constraint_name'+ ' AND kcu.table_name = '+EscapeString(Table.Name)+ ' GROUP BY'+ ' refc.constraint_name,'+ ' refc.update_rule,'+ ' refc.delete_rule,'+ ' kcu.table_name,'+ ' ccu.table_schema,'+ ' ccu.table_name'+ ' ORDER BY'+ ' ord_position' ); while not ForeignQuery.Eof do begin ForeignKey := TForeignKey.Create(Self); Result.Add(ForeignKey); ForeignKey.KeyName := ForeignQuery.Col('constraint_name'); ForeignKey.OldKeyName := ForeignKey.KeyName; ForeignKey.Db := Table.Schema; ForeignKey.ReferenceDb := ForeignQuery.Col('ref_schema'); ForeignKey.ReferenceTable := ForeignQuery.Col('ref_schema')+'.'+ForeignQuery.Col('ref_table'); ForeignKey.OnUpdate := ForeignQuery.Col('update_rule'); ForeignKey.OnDelete := ForeignQuery.Col('delete_rule'); ForeignKey.Columns.CommaText := ForeignQuery.Col('columns'); ForeignKey.ForeignColumns.CommaText := ForeignQuery.Col('ref_columns'); ForeignQuery.Next; end; ForeignQuery.Free; except // STRING_AGG() fails on pre-v9 servers, // and the alternative ARRAY_TO_STRING(ARRAY_AGG(x), ',') fails on v9+ servers // See https://www.heidisql.com/forum.php?t=36149 on E:EDbError do Log(lcError, 'Foreign key detection failed: '+E.Message); end; end; function TSQLiteConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList; var ForeignQuery: TDBQuery; ForeignKey: TForeignKey; begin // SQLite: query PRAGMA foreign_key_list Result := TForeignKeyList.Create(True); ForeignQuery := GetResults('SELECT * '+ 'FROM '+QuoteIdent(Table.Database)+'.pragma_foreign_key_list('+EscapeString(Table.Name)+')'); ForeignKey := nil; while not ForeignQuery.Eof do begin if (not Assigned(ForeignKey)) or (ForeignKey.KeyName <> ForeignQuery.Col('id')) then begin ForeignKey := TForeignKey.Create(Self); Result.Add(ForeignKey); ForeignKey.KeyName := ForeignQuery.Col('id'); ForeignKey.OldKeyName := ForeignKey.KeyName; ForeignKey.ReferenceTable := ForeignQuery.Col('table'); ForeignKey.OnUpdate := ForeignQuery.Col('on_update'); ForeignKey.OnDelete := ForeignQuery.Col('on_delete'); end; ForeignKey.Columns.Add(ForeignQuery.Col('from')); ForeignKey.ForeignColumns.Add(ForeignQuery.Col('to')); ForeignQuery.Next; end; ForeignQuery.Free; end; function TInterbaseConnection.GetTableForeignKeys(Table: TDBObject): TForeignKeyList; var ForeignQuery: TDBQuery; ForeignKey: TForeignKey; begin // SQLite: query PRAGMA foreign_key_list Result := TForeignKeyList.Create(True); ForeignQuery := GetResults( 'select strc.rdb$relation_name' +#13#10+ ' , strc.rdb$constraint_name' +#13#10+ ' , fkrc.rdb$relation_name as "ReferenceTable"' +#13#10+ ' , stis.rdb$field_name as "from"' +#13#10+ ' , fkis.rdb$field_name as "to"' +#13#10+ ' , rdb$ref_constraints.rdb$update_rule' +#13#10+ ' , rdb$ref_constraints.rdb$delete_rule' +#13#10+ ' from rdb$relation_constraints strc' +#13#10+ ' join rdb$ref_constraints on RDB$REF_CONSTRAINTS.rdb$constraint_name = strc.rdb$constraint_name' +#13#10+ ' join rdb$relation_constraints fkrc on fkrc.rdb$constraint_name = rdb$ref_constraints.rdb$const_name_uq' +#13#10+ ' join rdb$index_segments stis on stis.rdb$index_name = strc.rdb$index_name' +#13#10+ ' join rdb$index_segments fkis on fkis.rdb$index_name = fkrc.rdb$index_name' +#13#10+ ' where strc.rdb$relation_name = ' +QuotedStr(Table.Name)+#13#10+ ' and strc.rdb$constraint_type = ''FOREIGN KEY'''); ForeignKey := nil; while not ForeignQuery.Eof do begin if (not Assigned(ForeignKey)) or (ForeignKey.KeyName <> ForeignQuery.Col('rdb$constraint_name')) then begin ForeignKey := TForeignKey.Create(Self); Result.Add(ForeignKey); ForeignKey.KeyName := ForeignQuery.Col('rdb$constraint_name'); ForeignKey.OldKeyName := ForeignKey.KeyName; ForeignKey.ReferenceTable := ForeignQuery.Col('ReferenceTable'); ForeignKey.OnUpdate := ForeignQuery.Col('rdb$update_rule'); ForeignKey.OnDelete := ForeignQuery.Col('rdb$delete_rule'); end; ForeignKey.Columns.Add(ForeignQuery.Col('from')); ForeignKey.ForeignColumns.Add(ForeignQuery.Col('to')); ForeignQuery.Next; end; ForeignQuery.Free; end; function TDBConnection.GetTableCheckConstraints(Table: TDBObject): TCheckConstraintList; var CheckQuery: TDBQuery; CheckConstraint: TCheckConstraint; ConTableIdx, TconTableIdx: Integer; begin Result := TCheckConstraintList.Create(True); ConTableIdx := FInformationSchemaObjects.IndexOf('CHECK_CONSTRAINTS'); TconTableIdx := FInformationSchemaObjects.IndexOf('TABLE_CONSTRAINTS'); if (ConTableIdx = -1) or (TconTableIdx = -1) then Exit; try if FParameters.IsMariaDB then begin CheckQuery := GetResults('SELECT CONSTRAINT_NAME, CHECK_CLAUSE'+ ' FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent(FInformationSchemaObjects[ConTableIdx])+ ' WHERE'+ ' '+Table.SchemaClauseIS('CONSTRAINT')+ ' AND TABLE_NAME='+EscapeString(Table.Name) ); end else begin CheckQuery := GetResults('SELECT tc.CONSTRAINT_NAME, cc.CHECK_CLAUSE'+ ' FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent(FInformationSchemaObjects[ConTableIdx])+' AS cc, '+ QuoteIdent(InfSch)+'.'+QuoteIdent(FInformationSchemaObjects[TconTableIdx])+' AS tc'+ ' WHERE'+ ' '+Table.SchemaClauseIS('tc.CONSTRAINT')+ ' AND tc.TABLE_NAME='+EscapeString(Table.Name)+ ' AND tc.CONSTRAINT_TYPE='+EscapeString('CHECK')+ ' AND tc.CONSTRAINT_SCHEMA=cc.CONSTRAINT_SCHEMA'+ ' AND tc.CONSTRAINT_NAME=cc.CONSTRAINT_NAME'+ IfThen(FParameters.IsAnyPostgreSQL, ' AND cc.CONSTRAINT_NAME NOT LIKE '+EscapeString('%\_not\_null'), '') ); end; while not CheckQuery.Eof do begin CheckConstraint := TCheckConstraint.Create(Self); Result.Add(CheckConstraint); CheckConstraint.Name := CheckQuery.Col('CONSTRAINT_NAME'); CheckConstraint.CheckClause := CheckQuery.Col('CHECK_CLAUSE'); CheckQuery.Next; end; CheckQuery.Free; except on E:EDbError do begin Log(lcError, 'Detection of check constraints disabled due to error in query'); // Table is likely not there or does not have expected columns - prevent further queries with the same error: FInformationSchemaObjects.Delete(ConTableIdx); end; end; end; function TDBConnection.IsHex(Text: String): Boolean; var i, Len: Integer; const HexChars: TSysCharSet = ['0'..'9','a'..'f', 'A'..'F']; begin // Check first kilobyte of passed text whether it's a hex encoded string. Hopefully faster than a regex. Result := False; Len := Length(Text); if (Len >= 4) and (Len mod 2 = 0) then begin Result := (Text[1] = '0') and (Text[2] = 'x'); if Result then begin for i:=3 to SIZE_KB do begin if not CharInSet(Text[i], HexChars) then begin Result := False; Break; end; if i >= Len then Break; end; end; end; end; function TMySQLConnection.GetRowCount(Obj: TDBObject): Int64; var Rows: String; begin // Get row number from a mysql table if Parameters.IsProxySQLAdmin then Rows := GetVar('SELECT COUNT(*) FROM '+QuoteIdent(Obj.Database)+'.'+QuoteIdent(Obj.Name), 0) else Rows := GetVar('SHOW TABLE STATUS LIKE '+EscapeString(Obj.Name), 'Rows'); Result := MakeInt(Rows); end; function TAdoDBConnection.GetRowCount(Obj: TDBObject): Int64; var Rows: String; begin // Get row number from a mssql table if ServerVersionInt >= 900 then begin Rows := GetVar('SELECT SUM('+QuoteIdent('rows')+') FROM '+QuoteIdent('sys')+'.'+QuoteIdent('partitions')+ ' WHERE '+QuoteIdent('index_id')+' IN (0, 1)'+ ' AND '+QuoteIdent('object_id')+' = object_id('+EscapeString(Obj.Database+'.'+Obj.Schema+'.'+Obj.Name)+')' ); end else begin Rows := GetVar('SELECT COUNT(*) FROM '+Obj.QuotedDbAndTableName); end; Result := MakeInt(Rows); end; function TPgConnection.GetRowCount(Obj: TDBObject): Int64; var Rows: String; begin // Get row number from a postgres table Rows := GetVar('SELECT '+QuoteIdent('reltuples')+'::bigint FROM '+QuoteIdent('pg_class')+ ' LEFT JOIN '+QuoteIdent('pg_namespace')+ ' ON ('+QuoteIdent('pg_namespace')+'.'+QuoteIdent('oid')+' = '+QuoteIdent('pg_class')+'.'+QuoteIdent('relnamespace')+')'+ ' WHERE '+QuoteIdent('pg_class')+'.'+QuoteIdent('relkind')+'='+EscapeString('r')+ ' AND '+QuoteIdent('pg_namespace')+'.'+QuoteIdent('nspname')+'='+EscapeString(Obj.Database)+ ' AND '+QuoteIdent('pg_class')+'.'+QuoteIdent('relname')+'='+EscapeString(Obj.Name) ); Result := MakeInt(Rows); end; function TSQLiteConnection.GetRowCount(Obj: TDBObject): Int64; var Rows: String; begin // Get row number from a table Rows := GetVar('SELECT COUNT(*) FROM '+QuoteIdent(Obj.Database)+'.'+QuoteIdent(Obj.Name), 0); Result := MakeInt(Rows); end; function TInterbaseConnection.GetRowCount(Obj: TDBObject): Int64; var Rows: String; begin // Get row number from a table Rows := GetVar('SELECT COUNT(*) FROM '+QuoteIdent(Obj.Database)+'.'+QuoteIdent(Obj.Name), 0); Result := MakeInt(Rows); end; procedure TDBConnection.Drop(Obj: TDBObject); begin Query('DROP '+UpperCase(Obj.ObjType)+' '+Obj.QuotedName); end; procedure TPgConnection.Drop(Obj: TDBObject); var sql: String; i: Integer; Params: TRoutineParamList; begin case Obj.NodeType of lntFunction, lntProcedure: begin sql := 'DROP '+UpperCase(Obj.ObjType)+' '+Obj.QuotedName+'('; Params := TRoutineParamList.Create; ParseRoutineStructure(Obj, Params); for i:=0 to Params.Count-1 do begin if Obj.NodeType = lntProcedure then sql := sql + Params[i].Context + ' '; sql := sql + QuoteIdent(Params[i].Name) + ' ' + Params[i].Datatype; if i < Params.Count-1 then sql := sql + ', '; end; sql := sql + ')'; Query(sql); end; else inherited; end; end; function TDBConnection.GetSQLSpecifity(Specifity: TSQLSpecifityId): String; begin // Return some version specific SQL clause or snippet Result := FSQLSpecifities[Specifity]; end; function TDBConnection.GetSQLSpecifity(Specifity: TSQLSpecifityId; const Args: array of const): String; begin Result := GetSQLSpecifity(Specifity); Result := Format(Result, Args); end; function TDBConnection.ResultCount; begin case Parameters.NetTypeGroup of ngMySQL: Result := Length(TMySQLConnection(Self).LastRawResults); ngMSSQL: Result := Length(TAdoDBConnection(Self).LastRawResults); ngPgSQL: Result := Length(TPGConnection(Self).LastRawResults); ngSQLite: Result := Length(TSQLiteConnection(Self).LastRawResults); ngInterbase: Result := Length(TInterbaseConnection(Self).LastRawResults); else raise Exception.CreateFmt(_(MsgUnhandledNetType), [Integer(Parameters.NetType)]); end; end; function TDBConnection.GetConnectionUptime: Integer; begin // Return seconds since last connect if not FActive then Result := 0 else Result := (GetTickCount div 1000) - FConnectionStarted; end; function TDBConnection.GetServerUptime: Integer; begin // Return server uptime in seconds. Return -1 if unknown. if FServerUptime > 0 then Result := Cardinal(FServerUptime) + ((GetTickCount div 1000) - FConnectionStarted) else Result := -1; end; function TDBConnection.GetServerNow: TDateTime; var d: TDateTime; begin // Return server datetime. Return -1 if unknown. if not FServerDateTimeOnStartup.IsEmpty then begin d := StrToDateTimeDef(FServerDateTimeOnStartup, 0); Result := IncSecond(d, (GetTickCount div 1000) - FConnectionStarted); end else Result := -1; end; function TDBConnection.GetCurrentUserHostCombination: String; begin // Return current user@host combination, used by various object editors for DEFINER clauses Log(lcDebug, 'Fetching user@host ...'); Ping(True); if FCurrentUserHostCombination.IsEmpty and (not GetSQLSpecifity(spCurrentUserHost).IsEmpty) then FCurrentUserHostCombination := GetVar(GetSQLSpecifity(spCurrentUserHost)) else FCurrentUserHostCombination := ''; Result := FCurrentUserHostCombination; end; function TDBConnection.GetAllUserHostCombinations: TStringList; begin // For populating combobox items if not Assigned(FAllUserHostCombinations) then begin try FAllUserHostCombinations := GetCol('SELECT CONCAT('+QuoteIdent('User')+', '+EscapeString('@')+', '+QuoteIdent('Host')+') '+ 'FROM '+QuoteIdent('mysql')+'.'+QuoteIdent('user')+' '+ 'WHERE '+QuoteIdent('User')+'!='+EscapeString('')+' '+ 'ORDER BY '+QuoteIdent('User')+', '+QuoteIdent('Host')); except on E:EDbError do FAllUserHostCombinations := TStringList.Create; end; end; Result := FAllUserHostCombinations; end; function TDBConnection.ExplainAnalyzer(SQL, DatabaseName: String): Boolean; begin Result := False; MessageDialog(_('Not implemented for this DBMS'), mtError, [mbOK]); end; function TMySQLConnection.ExplainAnalyzer(SQL, DatabaseName: String): Boolean; var Results: TDBQuery; Raw, URL: String; i: Integer; begin // Send EXPLAIN output to MariaDB.org Result := True; Database := DatabaseName; if SQL.Trim.IsEmpty then begin raise EDbError.Create(_('Please move the cursor inside the query you want to use.')); end; Results := GetResults('EXPLAIN '+SQL); Raw := '+' + CRLF + '|'; for i:=0 to Results.ColumnCount-1 do begin Raw := Raw + Results.ColumnNames[i] + '|'; end; Raw := Raw + CRLF + '+'; while not Results.Eof do begin Raw := Raw + CRLF + '|'; for i:=0 to Results.ColumnCount-1 do begin Raw := Raw + Results.Col(i) + '|'; end; Results.Next; end; Raw := Raw + CRLF; URL := 'https://mariadb.org/explain_analyzer/analyze/?raw_explain='+EncodeURLParam(Raw)+'&client='+APPNAME; ShellExec(URL); end; function TDBConnection.GetDateTimeValue(Input: String; Datatype: TDBDatatypeIndex): String; var rx: TRegExpr; begin // Return date/time string value as expected by server case Parameters.NetTypeGroup of ngMSSQL: begin rx := TRegExpr.Create; rx.Expression := '^(\d+\-\d+\-\d+)\s(\d+\:.+)$'; Result := Input; if rx.Exec(Input) then begin // Inject "T" between date and time, for MSSQL. See http://www.heidisql.com/forum.php?t=18441 Result := rx.Match[1] + 'T' + rx.Match[2]; end; rx.Free; end; else Result := Input; end; end; procedure TDBConnection.ClearCache(IncludeDBObjects: Boolean); begin // Free cached lists and results. Called when the connection was closed and/or destroyed PurgePrefetchResults; FreeAndNil(FCollationTable); FreeAndNil(FCharsetTable); FreeAndNil(FSessionVariables); FreeAndNil(FTableEngines); if IncludeDBObjects then begin ClearAllDbObjects; FColumnCache.Clear; FKeyCache.Clear; FForeignKeyCache.Clear; FCheckConstraintCache.Clear; end; FTableEngineDefault := ''; FCurrentUserHostCombination := ''; FThreadID := 0; end; procedure TDBConnection.ClearDbObjects(db: String); var i: Integer; begin // Free cached database object list for i:=FDatabaseCache.Count-1 downto 0 do begin if FDatabaseCache[i].Database = db then begin FDatabaseCache.Delete(i); end; end; end; procedure TDBConnection.ClearAllDbObjects; var i: Integer; begin for i:=FDatabaseCache.Count-1 downto 0 do begin if FDatabaseCache.Count > i then ClearDbObjects(FDatabaseCache[i].Database); end; end; function TDBConnection.DbObjectsCached(db: String): Boolean; var i: Integer; begin // Check if a table list is stored in cache Result := False; for i:=0 to FDatabaseCache.Count-1 do begin if FDatabaseCache[i].Database = db then begin Result := True; break; end; end; end; function TDBConnection.ParseDateTime(Str: String): TDateTime; var rx: TRegExpr; begin // Parse SQL date/time string value into a TDateTime Result := 0; rx := TRegExpr.Create; rx.Expression := '^(\d{4})\-(\d{2})\-(\d{2}) (\d{2})\:(\d{2})\:(\d{2})'; if rx.Exec(Str) then try Result := EncodeDateTime( StrToIntDef(rx.Match[1], 0), StrToIntDef(rx.Match[2], 1), StrToIntDef(rx.Match[3], 1), StrToIntDef(rx.Match[4], 0), StrToIntDef(rx.Match[5], 0), StrToIntDef(rx.Match[6], 0), 0 // milliseconds, unused ); except Result := 0; end; end; function TDBConnection.GetDbObjects(db: String; Refresh: Boolean=False; OnlyNodeType: TListNodeType=lntNone): TDBObjectList; var CacheAllTypes, TempList: TDBObjectList; i, j, ObjIndex: Integer; DbObjectCopy: TDBObject; begin // Cache and return a db's table list // Find all-types list in cache CacheAllTypes := nil; for i:=0 to FDatabaseCache.Count-1 do begin if (FDatabaseCache[i].Database = db) and (FDatabaseCache[i].OnlyNodeType=lntNone) then begin CacheAllTypes := FDatabaseCache[i]; Break; end; end; // First time creation of all-types list if CacheAllTypes = nil then begin CacheAllTypes := TDBObjectList.Create(TDBObjectComparer.Create, True); CacheAllTypes.FOnlyNodeType := lntNone; CacheAllTypes.FDatabase := db; CacheAllTypes.FObjectsLoaded := False; FDatabaseCache.Add(CacheAllTypes); end; // Fill all-types list if not yet fetched if (not CacheAllTypes.FObjectsLoaded) or Refresh then begin TempList := TDBObjectList.Create(TDBObjectComparer.Create, False); FetchDbObjects(db, TempList); // Find youngest last update for i:=0 to TempList.Count-1 do begin TempList.FLastUpdate := Max(TempList.FLastUpdate, Max(TempList[i].Updated, TempList[i].Created)); end; // Sort list like it get sorted in AnyGridCompareNodes TempList.Sort; CacheAllTypes.FLargestObjectSize := TempList.FLargestObjectSize; CacheAllTypes.FLastUpdate := TempList.FLastUpdate; CacheAllTypes.FDataSize := TempList.FDataSize; CacheAllTypes.FObjectsLoaded := True; // Assign templist properties to existing objects and add non existing for i:=0 to TempList.Count-1 do begin ObjIndex := -1; for j:=0 to CacheAllTypes.Count-1 do begin if CacheAllTypes[j].IsSameAs(TempList[i]) then begin ObjIndex := j; Break; end; end; if ObjIndex > -1 then CacheAllTypes[ObjIndex].Assign(TempList[i]) else CacheAllTypes.Add(TempList[i]); end; // Delete no longer existing for i:=0 to CacheAllTypes.Count-1 do begin ObjIndex := -1; for j:=0 to TempList.Count-1 do begin if TempList[j].IsSameAs(CacheAllTypes[i]) then begin ObjIndex := j; Break; end; end; if ObjIndex = -1 then CacheAllTypes.Delete(i); end; // Free list, clear detail caches and call change event TempList.Free; FColumnCache.Clear; FKeyCache.Clear; FForeignKeyCache.Clear; FCheckConstraintCache.Clear; if Assigned(FOnObjectnamesChanged) then FOnObjectnamesChanged(Self, db); end; // Now we can see if we already have a result with the right type. // All-types list is already there, so this first loop should find it. Result := nil; for i:=0 to FDatabaseCache.Count-1 do begin if (FDatabaseCache[i].Database = db) and (FDatabaseCache[i].OnlyNodeType=OnlyNodeType) then begin Result := FDatabaseCache[i]; break; end; end; // Certain-types list not yet in cache. Create and cache it if Result = nil then begin Result := TDBObjectList.Create(TDBObjectComparer.Create, True); Result.FOnlyNodeType := OnlyNodeType; Result.FLastUpdate := CacheAllTypes.FLastUpdate; Result.FDataSize := CacheAllTypes.FDataSize; Result.FObjectsLoaded := True; Result.FDatabase := CacheAllTypes.FDatabase; Result.FCollation := CacheAllTypes.FCollation; for i:=0 to CacheAllTypes.Count-1 do begin if CacheAllTypes[i].NodeType = OnlyNodeType then begin DbObjectCopy := TDBObject.Create(Self); DbObjectCopy.Assign(CacheAllTypes[i]); Result.Add(DbObjectCopy); end; end; FDatabaseCache.Add(Result); end; end; procedure TMySQLConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); var obj: TDBObject; Results: TDBQuery; rx: TRegExpr; begin // Return a db's table list try Cache.FCollation := GetVar('SELECT '+QuoteIdent('DEFAULT_COLLATION_NAME')+ ' FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent('SCHEMATA')+ ' WHERE '+QuoteIdent('SCHEMA_NAME')+'='+EscapeString(db)); except Cache.FCollation := ''; end; rx := TRegExpr.Create; rx.ModifierI := True; // Tables and views Results := nil; try if Parameters.IsProxySQLAdmin then begin Results := GetResults('SHOW TABLES FROM '+QuoteIdent(db)); end else if Parameters.FullTableStatus or (UpperCase(db) = UpperCase(InfSch)) then begin Results := GetResults('SHOW TABLE STATUS FROM '+QuoteIdent(db)); end else begin Results := GetResults('SELECT '+ QuoteIdent('TABLE_NAME')+' AS '+QuoteIdent('Name')+', '+ QuoteIdent('ENGINE')+' AS '+QuoteIdent('Engine')+', '+ QuoteIdent('VERSION')+' AS '+QuoteIdent('Version')+', '+ QuoteIdent('TABLE_COLLATION')+' AS '+QuoteIdent('Collation')+', '+ QuoteIdent('TABLE_COMMENT')+' AS '+QuoteIdent('Comment')+', '+ 'NULL AS '+QuoteIdent('Create_time')+', '+ 'NULL AS '+QuoteIdent('Update_time')+', '+ 'NULL AS '+QuoteIdent('Data_length')+', '+ 'NULL AS '+QuoteIdent('Index_length')+', '+ 'NULL AS '+QuoteIdent('Rows')+', '+ 'NULL AS '+QuoteIdent('Auto_increment')+', '+ 'NULL AS '+QuoteIdent('Row_format')+', '+ 'NULL AS '+QuoteIdent('Avg_row_length')+', '+ 'NULL AS '+QuoteIdent('Max_data_length')+', '+ 'NULL AS '+QuoteIdent('Data_free')+', '+ 'NULL AS '+QuoteIdent('Check_time')+', '+ 'NULL AS '+QuoteIdent('Checksum')+', '+ 'NULL AS '+QuoteIdent('Create_options')+ ' FROM '+InfSch+'.TABLES'+ ' WHERE TABLE_SCHEMA='+EscapeString(db)+' AND TABLE_TYPE IN('+EscapeString('BASE TABLE')+', '+EscapeString('VIEW')+')' ); end; except on E:EDbError do; end; if Assigned(Results) then begin while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col(0); obj.Database := db; obj.Rows := StrToInt64Def(Results.Col('Rows', True), -1); if (not Results.IsNull('Data_length')) and (not Results.IsNull('Index_length')) then begin Obj.Size := StrToInt64Def(Results.Col('Data_length', True), 0) + StrToInt64Def(Results.Col('Index_length', True), 0); Inc(Cache.FDataSize, Obj.Size); Cache.FLargestObjectSize := Max(Cache.FLargestObjectSize, Obj.Size); end; Obj.NodeType := lntTable; if Results.IsNull(1) and Results.IsNull(2) then // Engine column is NULL for views Obj.NodeType := lntView; Obj.Created := ParseDateTime(Results.Col('Create_time', True)); Obj.Updated := ParseDateTime(Results.Col('Update_time', True)); if Results.ColExists('Type') then Obj.Engine := Results.Col('Type', True) else Obj.Engine := Results.Col('Engine', True); Obj.Comment := Results.Col('Comment', True); // Sanitize comment from automatically appendage rx.Expression := '(;\s*)?InnoDB\s*free\:.*$'; Obj.Comment := rx.Replace(Obj.Comment, '', False); Obj.Version := StrToInt64Def(Results.Col('Version', True), Obj.Version); Obj.AutoInc := StrToInt64Def(Results.Col('Auto_increment', True), Obj.AutoInc); Obj.RowFormat := Results.Col('Row_format', True); Obj.AvgRowLen := StrToInt64Def(Results.Col('Avg_row_length', True), Obj.AvgRowLen); Obj.MaxDataLen := StrToInt64Def(Results.Col('Max_data_length', True), Obj.MaxDataLen); Obj.IndexLen := StrToInt64Def(Results.Col('Index_length', True), Obj.IndexLen); Obj.DataLen := StrToInt64Def(Results.Col('Data_length', True), Obj.DataLen); Obj.DataFree := StrToInt64Def(Results.Col('Data_free', True), Obj.DataFree); Obj.LastChecked := ParseDateTime(Results.Col('Check_time', True)); Obj.Collation := Results.Col('Collation', True); Obj.CheckSum := StrToInt64Def(Results.Col('Checksum', True), Obj.CheckSum); Obj.CreateOptions := Results.Col('Create_options', True); Results.Next; end; FreeAndNil(Results); end; // Stored functions if (ServerVersionInt >= 50000) and (not Parameters.IsProxySQLAdmin) then try Results := GetResults('SHOW FUNCTION STATUS WHERE '+QuoteIdent('Db')+'='+EscapeString(db)); except on E:EDbError do; end; if Assigned(Results) then begin while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('Name'); obj.Database := db; Obj.NodeType := lntFunction; Obj.Created := ParseDateTime(Results.Col('Created')); Obj.Updated := ParseDateTime(Results.Col('Modified')); Obj.Comment := Results.Col('Comment'); Results.Next; end; FreeAndNil(Results); end; // Stored procedures if (ServerVersionInt >= 50000) and (not Parameters.IsProxySQLAdmin) then try Results := GetResults('SHOW PROCEDURE STATUS WHERE '+QuoteIdent('Db')+'='+EscapeString(db)); except on E:EDbError do; end; if Assigned(Results) then begin while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('Name'); obj.Database := db; Obj.NodeType := lntProcedure; Obj.Created := ParseDateTime(Results.Col('Created')); Obj.Updated := ParseDateTime(Results.Col('Modified')); Obj.Comment := Results.Col('Comment'); Results.Next; end; FreeAndNil(Results); end; // Triggers if (ServerVersionInt >= 50010) and (not Parameters.IsProxySQLAdmin) then try Results := GetResults('SHOW TRIGGERS FROM '+QuoteIdent(db)); except on E:EDbError do; end; if Assigned(Results) then begin while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('Trigger'); obj.Database := db; Obj.NodeType := lntTrigger; Obj.Created := ParseDateTime(Results.Col('Created')); Obj.Comment := Results.Col('Timing')+' '+Results.Col('Event')+' in table '+QuoteIdent(Results.Col('Table')); Results.Next; end; FreeAndNil(Results); end; // Events if (ServerVersionInt >= 50100) and (not Parameters.IsProxySQLAdmin) then try Results := GetResults('SELECT *, EVENT_SCHEMA AS '+QuoteIdent('Db')+', EVENT_NAME AS '+QuoteIdent('Name')+ ' FROM '+InfSch+'.'+QuoteIdent('EVENTS')+' WHERE '+QuoteIdent('EVENT_SCHEMA')+'='+EscapeString(db)) except on E:EDbError do begin try Results := GetResults('SHOW EVENTS FROM '+QuoteIdent(db)); except on EDbError do; end; end; end; if Assigned(Results) then begin while not Results.Eof do begin if Results.Col('Db') = db then begin Obj := TDBObject.Create(Self); Cache.Add(obj); Obj.Name := Results.Col('Name'); Obj.Created := ParseDateTime(Results.Col('CREATED', True)); Obj.Updated := ParseDateTime(Results.Col('LAST_ALTERED', True)); Obj.LastChecked := ParseDateTime(Results.Col('STARTS', True)); Obj.Comment := Results.Col('EVENT_COMMENT', True); Obj.Size := Length(Results.Col('EVENT_DEFINITION', True)); Obj.Database := db; Obj.NodeType := lntEvent; end; Results.Next; end; FreeAndNil(Results); end; end; procedure TAdoDBConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); var obj: TDBObject; Results: TDBQuery; tp, SchemaSelect: String; begin // Tables, views and procedures Results := nil; // Schema support introduced in MSSQL 2005 (9.0). See issue #3212. SchemaSelect := EscapeString(''); if ServerVersionInt >= 900 then SchemaSelect := 'SCHEMA_NAME('+QuoteIdent('schema_id')+')'; try Results := GetResults('SELECT *, '+SchemaSelect+' AS '+EscapeString('schema')+ ' FROM '+QuoteIdent(db)+GetSQLSpecifity(spDbObjectsTable)+ ' WHERE '+QuoteIdent('type')+' IN ('+EscapeString('P')+', '+EscapeString('U')+', '+EscapeString('V')+', '+EscapeString('TR')+', '+EscapeString('FN')+', '+EscapeString('TF')+', '+EscapeString('IF')+')'); except on E:EDbError do; end; if Assigned(Results) then begin while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('name'); obj.Created := ParseDateTime(Results.Col(GetSQLSpecifity(spDbObjectsCreateCol), True)); obj.Updated := ParseDateTime(Results.Col(GetSQLSpecifity(spDbObjectsUpdateCol), True)); obj.Schema := Results.Col('schema'); obj.Database := db; tp := Trim(Results.Col(GetSQLSpecifity(spDbObjectsTypeCol), True)); if tp = 'U' then obj.NodeType := lntTable else if tp = 'P' then obj.NodeType := lntProcedure else if tp = 'V' then obj.NodeType := lntView else if tp = 'TR' then obj.NodeType := lntTrigger else if (tp = 'FN') or (tp = 'TF') or (tp = 'IF') then obj.NodeType := lntFunction; // Set reasonable default value for calculation of export chunks. See #343 // OFFSET..FETCH supported from v11.0/2012 if ServerVersionInt >= 1100 then obj.AvgRowLen := 10*SIZE_KB; Results.Next; end; FreeAndNil(Results); end; end; procedure TPGConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); var obj: TDBObject; Results: TDBQuery; tp, SchemaTable: String; DataLenClause, IndexLenClause: String; begin // Tables, views and procedures Results := nil; try // See http://www.heidisql.com/forum.php?t=16429 if ServerVersionInt >= 70300 then SchemaTable := 'QUOTE_IDENT(t.TABLE_SCHEMA) || '+EscapeString('.')+' || QUOTE_IDENT(t.TABLE_NAME)' else SchemaTable := EscapeString(FQuoteChar)+' || t.TABLE_SCHEMA || '+EscapeString(FQuoteChar+'.'+FQuoteChar)+' || t.TABLE_NAME || '+EscapeString(FQuoteChar); // See http://www.heidisql.com/forum.php?t=16996 if Parameters.FullTableStatus and (ServerVersionInt >= 90000) then DataLenClause := 'pg_table_size('+SchemaTable+')::bigint' else DataLenClause := 'NULL'; // See https://www.heidisql.com/forum.php?t=34635 if Parameters.FullTableStatus and (ServerVersionInt >= 80100) then IndexLenClause := 'pg_relation_size('+SchemaTable+')::bigint' else IndexLenClause := 'relpages::bigint * '+SIZE_KB.ToString; Results := GetResults('SELECT *,'+ ' '+DataLenClause+' AS data_length,'+ ' '+IndexLenClause+' AS index_length,'+ ' c.reltuples, obj_description(c.oid) AS comment'+ ' FROM '+QuoteIdent(InfSch)+'.'+QuoteIdent('tables')+' AS t'+ ' LEFT JOIN '+QuoteIdent('pg_namespace')+' n ON t.table_schema = n.nspname'+ ' LEFT JOIN '+QuoteIdent('pg_class')+' c ON n.oid = c.relnamespace AND c.relname=t.table_name'+ ' WHERE t.'+QuoteIdent('table_schema')+'='+EscapeString(db) // Use table_schema when using schemata ); except on E:EDbError do; end; if Assigned(Results) then begin while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('table_name'); obj.Created := 0; obj.Updated := 0; obj.Database := db; obj.Schema := Results.Col('table_schema'); // Remove when using schemata obj.Comment := Results.Col('comment'); obj.Rows := StrToInt64Def(Results.Col('reltuples'), obj.Rows); obj.DataLen := StrToInt64Def(Results.Col('data_length'), obj.DataLen); obj.IndexLen := StrToInt64Def(Results.Col('index_length'), obj.IndexLen); obj.Size := obj.DataLen + obj.IndexLen; Inc(Cache.FDataSize, Obj.Size); Cache.FLargestObjectSize := Max(Cache.FLargestObjectSize, Obj.Size); tp := Results.Col('table_type', True); if tp = 'VIEW' then obj.NodeType := lntView else obj.NodeType := lntTable; Results.Next; end; FreeAndNil(Results); end; // Stored functions. No procedures in PostgreSQL. // See http://dba.stackexchange.com/questions/2357/what-are-the-differences-between-stored-procedures-and-stored-functions try Results := GetResults('SELECT '+QuoteIdent('p')+'.'+QuoteIdent('proname')+', '+QuoteIdent('p')+'.'+QuoteIdent('proargtypes')+' '+ 'FROM '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_namespace')+' AS '+QuoteIdent('n')+' '+ 'JOIN '+QuoteIdent('pg_catalog')+'.'+QuoteIdent('pg_proc')+' AS '+QuoteIdent('p')+' ON '+QuoteIdent('p')+'.'+QuoteIdent('pronamespace')+' = '+QuoteIdent('n')+'.'+QuoteIdent('oid')+' '+ 'WHERE '+QuoteIdent('n')+'.'+QuoteIdent('nspname')+'='+EscapeString(db) ); except on E:EDbError do; end; if Assigned(Results) then begin while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('proname'); obj.ArgTypes := Results.Col('proargtypes'); obj.Database := db; obj.NodeType := lntFunction; Results.Next; end; FreeAndNil(Results); end; end; procedure TSQLiteConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); var obj: TDBObject; Results: TDBQuery; begin // Tables, views and procedures Results := nil; try Results := GetResults('SELECT * FROM '+QuoteIdent(db)+'.sqlite_master '+ 'WHERE type IN('+EscapeString('table')+', '+EscapeString('view')+') AND name NOT LIKE '+EscapeString('sqlite_%')); except on E:EDbError do; end; if Assigned(Results) then begin while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('name'); obj.Created := Now; obj.Updated := Now; obj.Database := db; if Results.Col('type').ToLowerInvariant = 'view' then begin obj.NodeType := lntView; obj.FCreateCode := Results.Col('sql'); end else obj.NodeType := lntTable; Results.Next; end; FreeAndNil(Results); end; end; procedure TInterbaseConnection.FetchDbObjects(db: String; var Cache: TDBObjectList); var obj: TDBObject; Results: TDBQuery; begin // Tables and views Results := nil; try Results := GetResults('SELECT RDB$RELATION_NAME, RDB$DESCRIPTION, RDB$RELATION_TYPE AS '+QuoteIdent('ViewContext') + ' FROM RDB$RELATIONS WHERE RDB$RELATIONS.RDB$SYSTEM_FLAG = 0'); try while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col(0); obj.Created := Now; obj.Updated := Now; obj.Database := db; obj.Comment := Results.Col('RDB$DESCRIPTION'); if Parameters.IsInterbase then begin if Results.Col('ViewContext') = 'PERSISTENT' then obj.NodeType := lntTable else obj.NodeType := lntView; end else begin if Results.Col('ViewContext') = '0' then obj.NodeType := lntTable else obj.NodeType := lntView; end; Results.Next; end; finally FreeAndNil(Results); end; except on E:EDbError do; end; // Procedures try Results := GetResults('SELECT RDB$PROCEDURE_NAME, RDB$DESCRIPTION FROM RDB$PROCEDURES WHERE RDB$SYSTEM_FLAG = 0'); try while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('RDB$PROCEDURE_NAME'); obj.Database := db; Obj.NodeType := lntProcedure; obj.Created := Now; obj.Updated := Now; Obj.Comment := Results.Col('RDB$DESCRIPTION'); Results.Next; end; finally FreeAndNil(Results); end; except on E:EDbError do; end; // Triggers try Results := GetResults('SELECT RDB$TRIGGER_NAME, RDB$DESCRIPTION FROM RDB$TRIGGERS WHERE RDB$SYSTEM_FLAG = 0'); try while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('RDB$TRIGGER_NAME'); obj.Database := db; Obj.NodeType := lntTrigger; obj.Created := Now; obj.Updated := Now; Obj.Comment := Results.Col('RDB$DESCRIPTION'); Results.Next; end; finally FreeAndNil(Results); end; except on E:EDbError do; end; // Functions try Results := GetResults('SELECT rdb$function_name, RDB$DESCRIPTION FROM rdb$functions WHERE RDB$SYSTEM_FLAG = 0'); try while not Results.Eof do begin obj := TDBObject.Create(Self); Cache.Add(obj); obj.Name := Results.Col('RDB$function_name'); obj.Database := db; Obj.NodeType := lntFunction; obj.Created := Now; obj.Updated := Now; Obj.Comment := Results.Col('RDB$DESCRIPTION'); Results.Next; end; finally FreeAndNil(Results); end; except on E:EDbError do; end; end; function TDBConnection.GetKeyColumns(Columns: TTableColumnList; Keys: TTableKeyList): TStringList; var i: Integer; AllowsNull: Boolean; Key: TTableKey; Col: TTableColumn; begin Result := TStringList.Create; // Find best key for updates // 1. round: find a primary key for Key in Keys do begin if Key.IndexType = TTableKey.PRIMARY then Result.Assign(Key.Columns); end; if Result.Count = 0 then begin // no primary key available -> 2. round: find a unique key for Key in Keys do begin if Key.IndexType = TTableKey.UNIQUE then begin // We found a UNIQUE key - better than nothing. Check if one of the key // columns allows NULLs which makes it dangerous to use in UPDATES + DELETES. AllowsNull := False; for i:=0 to Key.Columns.Count-1 do begin for Col in Columns do begin if Col.Name = Key.Columns[i] then AllowsNull := Col.AllowNull; if AllowsNull then break; end; if AllowsNull then break; end; if not AllowsNull then begin Result.Assign(Key.Columns); break; end; end; end; end; end; function TDBConnection.DecodeAPIString(a: AnsiString): String; begin if IsUnicode then Result := Utf8ToString(a) else Result := String(a); end; function TDBConnection.ConnectionInfo: TStringList; function EvalBool(B: Boolean): String; begin if B then Result := _('Yes') else Result := _('No'); end; begin Log(lcDebug, 'Get connection details ...'); Result := TStringList.Create; if Assigned(Parameters) then begin Result.Values[_('Host')] := Parameters.Hostname; Result.Values[_('Network type')] := Parameters.NetTypeName(True); end; Ping(False); Result.Values[_('Connected')] := EvalBool(FActive); if FActive then begin Result.Values[_('Real Hostname')] := FRealHostname; Result.Values[_('Server OS')] := ServerOS; Result.Values[_('Server version')] := FServerVersionUntouched; Result.Values[_('Connection port')] := IntToStr(Parameters.Port); Result.Values[_('Compressed protocol')] := EvalBool(Parameters.Compressed); Result.Values[_('Unicode enabled')] := EvalBool(IsUnicode); Result.Values[_('SSL enabled')] := EvalBool(IsSSL); if Assigned(FSessionVariables) then Result.Values['max_allowed_packet'] := FormatByteNumber(MaxAllowedPacket); end; end; function TMySQLConnection.ConnectionInfo: TStringList; var Infos, Val: String; rx: TRegExpr; begin Result := Inherited; Result.Values[f_('Client version (%s)', [FLib.DllFile])] := DecodeApiString(FLib.mysql_get_client_info); if FActive then begin Infos := DecodeApiString(FLib.mysql_stat(FHandle)); rx := TRegExpr.Create; rx.ModifierG := False; rx.Expression := '(\S.*)\:\s+(\S*)(\s+|$)'; if rx.Exec(Infos) then while True do begin Val := rx.Match[2]; if LowerCase(rx.Match[1]) = 'uptime' then Val := FormatTimeNumber(StrToFloatDef(Val, 0), True) else Val := FormatNumber(Val); Result.Values[_(rx.Match[1])] := Val; if not rx.ExecNext then break; end; rx.Free; end; end; function TAdoDBConnection.ConnectionInfo: TStringList; var ConnectionString: String; rx: TRegExpr; begin Result := Inherited; if FActive then begin // clear out password ConnectionString := FAdoHandle.ConnectionString; rx := TRegExpr.Create; rx.ModifierI := True; rx.Expression := '(\Wpassword=)([^;]*)'; ConnectionString := rx.Replace(ConnectionString, '${1}******', True); rx.Free; Result.Values[_('Connection string')] := ConnectionString; end; end; function TPgConnection.ConnectionInfo: TStringList; var v: String; major, minor, build: Integer; begin Result := Inherited; v := IntToStr(FLib.PQlibVersion); major := StrToIntDef(Copy(v, 1, Length(v)-4), 0); minor := StrToIntDef(Copy(v, Length(v)-3, 2), 0); build := StrToIntDef(Copy(v, Length(v)-1, 2), 0); Result.Values[f_('Client version (%s)', [FLib.DllFile])] := IntToStr(major) + '.' + IntToStr(minor) + '.' + IntToStr(build); end; procedure TDBConnection.ParseViewStructure(CreateCode: String; DBObj: TDBObject; var Algorithm, Definer, SQLSecurity, CheckOption, SelectCode: String); var rx: TRegExpr; EscQuote: String; begin if CreateCode <> '' then begin // CREATE // [OR REPLACE] // [ALGORITHM = {UNDEFINED | MERGE | TEMPTABLE}] // [DEFINER = { user | CURRENT_USER }] // [SQL SECURITY { DEFINER | INVOKER }] // VIEW view_name [(column_list)] // AS select_statement // [WITH [CASCADED | LOCAL] CHECK OPTION] rx := TRegExpr.Create; rx.ModifierG := False; rx.ModifierI := True; EscQuote := QuoteRegExprMetaChars(FQuoteChar); rx.Expression := 'CREATE\s+(OR\s+REPLACE\s+)?'+ '(ALGORITHM\s*=\s*(\w*)\s*)?'+ '(DEFINER\s*=\s*(\S+|'+EscQuote+'[^@'+EscQuote+']+'+EscQuote+'@'+EscQuote+'[^'+EscQuote+']+'+EscQuote+')\s+)?'+ '(SQL\s+SECURITY\s+(\S+)\s+)?'+ 'VIEW\s+[^\(]+\s+'+ '(\([^\)]+\)\s+)?'+ 'AS\s+(.+)(\s+WITH\s+(\w+\s+)?CHECK\s+OPTION\s*)?$'; if rx.Exec(CreateCode) then begin Algorithm := rx.Match[3]; Definer := DeQuoteIdent(rx.Match[5], '@'); SQLSecurity := rx.Match[7]; if SQLSecurity.IsEmpty then SQLSecurity := 'DEFINER'; CheckOption := Trim(rx.Match[11]); SelectCode := rx.Match[9]; end else raise Exception.CreateFmt(_('Regular expression did not match the VIEW code in %s: %s'), ['ParseViewStructure()', CRLF+CRLF+CreateCode]); rx.Free; end; end; procedure TDBConnection.ParseRoutineStructure(Obj: TDBObject; Parameters: TRoutineParamList); var CreateCode, Params, Body, Match: String; ParenthesesCount: Integer; rx: TRegExpr; i: Integer; Param: TRoutineParam; InLiteral: Boolean; begin // Parse CREATE code of stored function or procedure to detect parameters rx := TRegExpr.Create; rx.ModifierI := True; rx.ModifierG := True; // CREATE DEFINER=`root`@`localhost` PROCEDURE `bla2`(IN p1 INT, p2 VARCHAR(20)) // CREATE DEFINER=`root`@`localhost` FUNCTION `test3`(`?b` varchar(20)) RETURNS tinyint(4) // CREATE DEFINER=`root`@`localhost` PROCEDURE `test3`(IN `Param1` int(1) unsigned) // MSSQL: CREATE FUNCTION dbo.ConvertToInt(@string nvarchar(255), @maxValue int, @defValue int) RETURNS int CreateCode := Obj.CreateCode; rx.Expression := '\bDEFINER\s*=\s*(\S+)\s'; if rx.Exec(CreateCode) then Obj.Definer := DequoteIdent(rx.Match[1], '@') else Obj.Definer := ''; // Parse parameter list ParenthesesCount := 0; Params := ''; InLiteral := False; for i:=1 to Length(CreateCode) do begin if (CreateCode[i] = ')') and (not InLiteral) then begin Dec(ParenthesesCount); if ParenthesesCount = 0 then break; end; if Pos(CreateCode[i], FQuoteChars) > 0 then InLiteral := not InLiteral; if ParenthesesCount >= 1 then Params := Params + CreateCode[i]; if (CreateCode[i] = '(') and (not InLiteral) then Inc(ParenthesesCount); end; Params := TSQLBatch.GetSQLWithoutComments(Params); // Extract parameters from left part rx.Expression := '(^|,)\s*((IN|OUT|INOUT)\s+)?(\S+)\s+([^\s,\(]+(\([^\)]*\))?[^,]*)'; if rx.Exec(Params) then while true do begin Param := TRoutineParam.Create; Param.Context := UpperCase(rx.Match[3]); if Param.Context = '' then Param.Context := 'IN'; Param.Name := DeQuoteIdent(rx.Match[4]); Param.Datatype := Trim(rx.Match[5]); Parameters.Add(Param); if not rx.ExecNext then break; end; // Right part contains routine body Body := Copy(CreateCode, i+1, Length(CreateCode)); // Remove "RETURNS x" and routine characteristics from body // LANGUAGE SQL // | [NOT] DETERMINISTIC // | { CONTAINS SQL | NO SQL | READS SQL DATA | MODIFIES SQL DATA } // | SQL SECURITY { DEFINER | INVOKER } // | COMMENT 'string' rx.Expression := '^\s*('+ 'RETURNS\s+(\S+(\s+UNSIGNED)?(\s+CHARSET\s+\S+)?(\s+COLLATE\s\S+)?)|'+ // MySQL function characteristics - see http://dev.mysql.com/doc/refman/5.1/de/create-procedure.html 'LANGUAGE\s+SQL|'+ '(NOT\s+)?DETERMINISTIC|'+ 'CONTAINS\s+SQL|'+ 'NO\s+SQL|'+ 'READS\s+SQL\s+DATA|'+ 'MODIFIES\s+SQL\s+DATA|'+ 'SQL\s+SECURITY\s+(DEFINER|INVOKER)|'+ // MS SQL function options - see http://msdn.microsoft.com/en-us/library/ms186755.aspx 'AS|'+ 'WITH\s+ENCRYPTION|'+ 'WITH\s+SCHEMABINDING|'+ 'WITH\s+RETURNS\s+NULL\s+ON\s+NULL\s+INPUT|'+ 'WITH\s+CALLED\s+ON\s+NULL\s+INPUT|'+ 'WITH\s+EXECUTE_AS_Clause'+ ')\s'; if rx.Exec(Body) then while true do begin Match := UpperCase(rx.Match[1]); if Pos('RETURNS', Match) = 1 then Obj.Returns := rx.Match[2] else if Pos('DETERMINISTIC', Match) = 1 then Obj.Deterministic := True else if Pos('NOT DETERMINISTIC', Match) = 1 then Obj.Deterministic := False else if (Pos('CONTAINS SQL', Match) = 1) or (Pos('NO SQL', Match) = 1) or (Pos('READS SQL DATA', Match) = 1) or (Pos('MODIFIES SQL DATA', Match) = 1) then Obj.DataAccess := rx.Match[1] else if Pos('SQL SECURITY', Match) = 1 then Obj.Security := rx.Match[7]; Delete(Body, 1, rx.MatchLen[0]); if not rx.Exec(Body) then break; end; Obj.Comment := ExtractLiteral(Body, 'COMMENT'); Obj.Body := TrimLeft(Body); rx.Free; end; procedure TDBConnection.PurgePrefetchResults; begin // Remove cached results if Assigned(FPrefetchResults) then FreeAndNil(FPrefetchResults); end; function TDBConnection.ApplyLimitClause(QueryType, QueryBody: String; Limit, Offset: Int64): String; begin QueryType := UpperCase(QueryType); Result := QueryType + ' '; case FParameters.NetTypeGroup of ngMSSQL: begin if (QueryType = 'UPDATE') or (QueryType = 'DELETE') then begin // TOP(x) clause for UPDATES + DELETES introduced in MSSQL 2005 if ServerVersionInt >= 900 then Result := Result + 'TOP('+IntToStr(Limit)+') '; Result := Result + QueryBody; end else if QueryType = 'SELECT' then begin if ServerVersionInt >= 1100 then begin Result := Result + QueryBody; if not ContainsText(Result, ' ORDER BY ') then Result := Result + ' ORDER BY 1'; // mandatory for using with OFFSET/FETCH Result := Result + ' OFFSET '+Offset.ToString+' ROWS FETCH NEXT '+Limit.ToString+' ROWS ONLY'; end else begin // OFFSET not supported in < 2012 Result := Result + 'TOP ' + IntToStr(Limit) + ' ' + QueryBody; end; end else Result := Result + QueryBody; end; ngMySQL: begin Result := Result + QueryBody + ' LIMIT '; if Offset > 0 then Result := Result + IntToStr(Offset) + ', '; Result := Result + IntToStr(Limit); end; ngPgSQL: begin if QueryType = 'SELECT' then begin Result := Result + QueryBody + ' LIMIT ' + IntToStr(Limit); if Offset > 0 then Result := Result + ' OFFSET ' + IntToStr(Offset); end else Result := Result + QueryBody; end; ngSQLite: begin // LIMIT supported only in SELECT queries // For UPDATEs and DELETEs only if we would compile sqlite library with SQLITE_ENABLE_UPDATE_DELETE_LIMIT compile flag Result := Result + QueryBody; if Result.StartsWith('SELECT') then begin Result := Result + ' LIMIT '; if Offset > 0 then Result := Result + IntToStr(Offset) + ', '; Result := Result + IntToStr(Limit); end; end; ngInterbase: begin // No support for limit nor offset Result := Result + QueryBody; end; end; end; function TDBConnection.LikeClauseTail: String; begin case FParameters.NetTypeGroup of ngMSSQL: Result := ' ESCAPE ' + EscapeString('\'); else Result := ''; end; end; { TMySQLQuery } constructor TDBQuery.Create(AOwner: TComponent); begin inherited Create(AOwner); FConnection := AOwner as TDbConnection; FRecNo := -1; FRecordCount := 0; FColumnNames := TStringList.Create; FColumnNames.CaseSensitive := False; FColumnOrgNames := TStringList.Create; FColumnOrgNames.CaseSensitive := False; FStoreResult := True; FDBObject := nil; FFormatSettings := TFormatSettings.Create('en-US'); end; constructor TMySQLQuery.Create(AOwner: TComponent); begin inherited Create(AOwner); // suspicous state here - what type has FConnection now? FConnection := AOwner as TMySQLConnection; end; constructor TPgQuery.Create(AOwner: TComponent); begin inherited Create(AOwner); FConnection := AOwner as TPgConnection; end; constructor TSQLiteQuery.Create(AOwner: TComponent); begin inherited Create(AOwner); FConnection := AOwner as TSQLiteConnection; end; constructor TInterbaseQuery.Create(AOwner: TComponent); begin inherited Create(AOwner); FConnection := AOwner as TInterbaseConnection; end; destructor TDBQuery.Destroy; begin FreeAndNil(FColumnNames); FreeAndNil(FColumnOrgNames); FreeAndNil(FColumns); FreeAndNil(FKeys); FreeAndNil(FUpdateData); if FDBObject <> nil then FDBObject.Free; SetLength(FColumnFlags, 0); SetLength(FColumnLengths, 0); SetLength(FColumnTypes, 0); FSQL := ''; FRecordCount := 0; inherited; end; destructor TMySQLQuery.Destroy; var i: Integer; begin if HasResult and (FConnection <> nil) and (FConnection.Active) then begin for i:=Low(FResultList) to High(FResultList) do FConnection.Lib.mysql_free_result(FResultList[i]); end; SetLength(FResultList, 0); inherited; end; destructor TAdoDBQuery.Destroy; var i: Integer; begin if HasResult and (FConnection <> nil) and (FConnection.Active) then begin for i:=Low(FResultList) to High(FResultList) do begin FResultList[i].Close; FResultList[i].Free; end; end; SetLength(FResultList, 0); inherited; end; destructor TPGQuery.Destroy; var i: Integer; begin if HasResult and (FConnection <> nil) and (FConnection.Active) then begin for i:=Low(FResultList) to High(FResultList) do FConnection.Lib.PQclear(FResultList[i]); end; SetLength(FResultList, 0); inherited; end; destructor TSQLiteQuery.Destroy; var i: Integer; begin if HasResult and (FConnection <> nil) and (FConnection.Active) then begin for i:=Low(FResultList) to High(FResultList) do FResultList[i].Free; end; SetLength(FResultList, 0); inherited; end; destructor TInterbaseQuery.Destroy; var i: Integer; begin if HasResult and (FConnection <> nil) and (FConnection.Active) then begin for i:=Low(FResultList) to High(FResultList) do begin FResultList[i].Close; FResultList[i].Free; end; end; SetLength(FResultList, 0); inherited; end; procedure TMySQLQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); var i, j, NumFields, NumResults: Integer; Field: PMYSQL_FIELD; IsBinary: Boolean; LastResult: PMYSQL_RES; begin // Execute a query, or just take over one of the last result pointers if UseRawResult = -1 then begin Connection.Query(FSQL, FStoreResult); UseRawResult := 0; end; if Connection.ResultCount > UseRawResult then begin LastResult := TMySQLConnection(Connection).LastRawResults[UseRawResult] end else begin LastResult := nil; end; if AddResult and (Length(FResultList) = 0) then AddResult := False; if AddResult then NumResults := Length(FResultList)+1 else begin for i:=Low(FResultList) to High(FResultList) do begin FConnection.Lib.mysql_free_result(FResultList[i]); end; NumResults := 1; FRecordCount := 0; FAutoIncrementColumn := -1; FEditingPrepared := False; end; if LastResult <> nil then begin Connection.Log(lcDebug, 'Result #'+IntToStr(NumResults)+' fetched.'); SetLength(FResultList, NumResults); FResultList[NumResults-1] := LastResult; FRecordCount := FRecordCount + LastResult.row_count; end; if not AddResult then begin if HasResult then begin // FCurrentResults is normally done in SetRecNo, but never if result has no rows FCurrentResults := LastResult; NumFields := FConnection.Lib.mysql_num_fields(LastResult); SetLength(FColumnTypes, NumFields); SetLength(FColumnLengths, NumFields); SetLength(FColumnFlags, NumFields); FColumnNames.Clear; FColumnOrgNames.Clear; for i:=0 to NumFields-1 do begin Field := FConnection.Lib.mysql_fetch_field_direct(LastResult, i); FColumnNames.Add(Connection.DecodeAPIString(Field.name)); if Connection.ServerVersionInt >= 40100 then FColumnOrgNames.Add(Connection.DecodeAPIString(Field.org_name)) else FColumnOrgNames.Add(Connection.DecodeAPIString(Field.name)); FColumnFlags[i] := Field.flags; FColumnTypes[i] := FConnection.Datatypes[0]; if (Field.flags and AUTO_INCREMENT_FLAG) = AUTO_INCREMENT_FLAG then FAutoIncrementColumn := i; for j:=0 to High(FConnection.Datatypes) do begin if (Field.flags and ENUM_FLAG) = ENUM_FLAG then begin if FConnection.Datatypes[j].Index = dbdtEnum then FColumnTypes[i] := FConnection.Datatypes[j]; end else if (Field.flags and SET_FLAG) = SET_FLAG then begin if FConnection.Datatypes[j].Index = dbdtSet then FColumnTypes[i] := FConnection.Datatypes[j]; end else if Field._type = Cardinal(FConnection.Datatypes[j].NativeType) then begin // Text and Blob types share the same constants (see FIELD_TYPEs) // See http://dev.mysql.com/doc/refman/5.7/en/c-api-data-structures.html if Connection.IsUnicode then IsBinary := Field.charsetnr = COLLATION_BINARY else IsBinary := (Field.flags and BINARY_FLAG) = BINARY_FLAG; if IsBinary and (FConnection.Datatypes[j].Category = dtcText) then continue; FColumnTypes[i] := FConnection.Datatypes[j]; Break; end; end; FConnection.Log(lcDebug, 'Detected column type for '+FColumnNames[i]+' ('+IntToStr(Field._type)+'): '+FColumnTypes[i].Name); end; FRecNo := -1; First; end else begin SetLength(FColumnTypes, 0); SetLength(FColumnLengths, 0); SetLength(FColumnFlags, 0); end; end; end; procedure TAdoDBQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); var i, j, NumFields, NumResults: Integer; TypeIndex: TDBDatatypeIndex; LastResult: TAdoQuery; begin // TODO: Handle multiple results if UseRawResult = -1 then begin Connection.Query(FSQL, FStoreResult); UseRawResult := 0; end; if Connection.ResultCount > UseRawResult then begin LastResult := TAdoQuery.Create(Self); LastResult.Recordset := TAdoDBConnection(Connection).LastRawResults[UseRawResult]; LastResult.Open; end else begin LastResult := nil; end; if AddResult and (Length(FResultList) = 0) then AddResult := False; if AddResult then NumResults := Length(FResultList)+1 else begin for i:=Low(FResultList) to High(FResultList) do begin FResultList[i].Close; FResultList[i].Free; end; NumResults := 1; FRecordCount := 0; FAutoIncrementColumn := -1; FEditingPrepared := False; end; if LastResult <> nil then begin Connection.Log(lcDebug, 'Result #'+IntToStr(NumResults)+' fetched.'); SetLength(FResultList, NumResults); FResultList[NumResults-1] := LastResult; FRecordCount := FRecordCount + LastResult.RecordCount; end; // Set up columns and data types if not AddResult then begin if HasResult then begin FCurrentResults := LastResult; NumFields := LastResult.FieldCount; SetLength(FColumnTypes, NumFields); SetLength(FColumnLengths, NumFields); SetLength(FColumnFlags, NumFields); FColumnNames.Clear; FColumnOrgNames.Clear; for i:=0 to NumFields-1 do begin FColumnNames.Add(LastResult.Fields[i].FieldName); FColumnOrgNames.Add(FColumnNames[i]); { ftUnknown, ftString, ftSmallint, ftInteger, ftWord, // 0..4 ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime, // 5..11 ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, // 12..18 ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString, // 19..24 ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, // 25..31 ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd, // 32..37 ftFixedWideChar, ftWideMemo, ftOraTimeStamp, ftOraInterval, // 38..41 ftLongWord, ftShortint, ftByte, ftExtended, ftConnection, ftParams, ftStream, //42..48 ftTimeStampOffset, ftObject, ftSingle //49..51 } case LastResult.Fields[i].DataType of ftSmallint, ftWord: TypeIndex := dbdtMediumInt; ftInteger: TypeIndex := dbdtInt; ftAutoInc: begin TypeIndex := dbdtInt; FAutoIncrementColumn := i; end; ftLargeint: TypeIndex := dbdtBigInt; ftBCD, ftFMTBcd: TypeIndex := dbdtDecimal; ftFixedChar, ftFixedWideChar: TypeIndex := dbdtChar; ftString, ftWideString, ftBoolean, ftGuid: TypeIndex := dbdtVarchar; ftMemo, ftWideMemo: TypeIndex := dbdtText; ftBlob, ftVariant: TypeIndex := dbdtMediumBlob; ftBytes: TypeIndex := dbdtBinary; ftVarBytes: TypeIndex := dbdtVarbinary; ftFloat: TypeIndex := dbdtFloat; ftDate: TypeIndex := dbdtDate; ftTime: TypeIndex := dbdtTime; ftDateTime: TypeIndex := dbdtDateTime; //ftTimeStampOffset: // this is NOT data type DATETIMEOFFSET // TypeIndex := dbdtDatetime; else raise EDbError.CreateFmt(_('Unknown data type for column #%d - %s: %d'), [i, FColumnNames[i], Integer(LastResult.Fields[i].DataType)]); end; for j:=0 to High(FConnection.DataTypes) do begin if TypeIndex = FConnection.DataTypes[j].Index then FColumnTypes[i] := FConnection.DataTypes[j]; end; end; FRecNo := -1; First; end else begin SetLength(FColumnTypes, 0); SetLength(FColumnLengths, 0); SetLength(FColumnFlags, 0); end; end; end; procedure TPGQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); var i, NumFields, NumResults: Integer; FieldTypeOID: POid; LastResult: PPGresult; begin if UseRawResult = -1 then begin Connection.Query(FSQL, FStoreResult); UseRawResult := 0; end; if Connection.ResultCount > UseRawResult then begin LastResult := TPGConnection(Connection).LastRawResults[UseRawResult] end else begin LastResult := nil; end; if AddResult and (Length(FResultList) = 0) then AddResult := False; if AddResult then NumResults := Length(FResultList)+1 else begin for i:=Low(FResultList) to High(FResultList) do begin FConnection.Lib.PQclear(FResultList[i]); end; NumResults := 1; FRecordCount := 0; FAutoIncrementColumn := -1; FEditingPrepared := False; end; if LastResult <> nil then begin Connection.Log(lcDebug, 'Result #'+IntToStr(NumResults)+' fetched.'); SetLength(FResultList, NumResults); FResultList[NumResults-1] := LastResult; FRecordCount := FRecordCount + FConnection.Lib.PQntuples(LastResult); end; if not AddResult then begin if HasResult then begin // FCurrentResults is normally done in SetRecNo, but never if result has no rows FCurrentResults := LastResult; NumFields := FConnection.Lib.PQnfields(LastResult); SetLength(FColumnTypes, NumFields); SetLength(FColumnLengths, NumFields); SetLength(FColumnFlags, NumFields); FColumnNames.Clear; FColumnOrgNames.Clear; for i:=0 to NumFields-1 do begin FColumnNames.Add(Connection.DecodeAPIString(FConnection.Lib.PQfname(LastResult, i))); FColumnOrgNames.Add(FColumnNames[FColumnNames.Count-1]); FieldTypeOID := FConnection.Lib.PQftype(LastResult, i); FColumnTypes[i] := FConnection.GetDatatypeByNativeType(FieldTypeOID, FColumnNames[FColumnNames.Count-1]); end; FRecNo := -1; First; end else begin SetLength(FColumnTypes, 0); SetLength(FColumnLengths, 0); SetLength(FColumnFlags, 0); end; end; end; procedure TSQLiteQuery.Execute(AddResult: Boolean=False; UseRawResult: Integer=-1); var i, NumFields, NumResults: Integer; LastResult: TSQLiteGridRows; ColName, ColOrgName, DataTypeStr: String; StepResult: Integer; begin if UseRawResult = -1 then begin Connection.Query(FSQL, FStoreResult); UseRawResult := 0; end; if Connection.ResultCount > UseRawResult then begin LastResult := TSQLiteConnection(Connection).LastRawResults[UseRawResult]; end else begin LastResult := nil; end; if AddResult and (Length(FResultList) = 0) then AddResult := False; if AddResult then NumResults := Length(FResultList)+1 else begin for i:=Length(FResultList)-1 downto 0 do begin FResultList[i].Free; end; NumResults := 1; FRecordCount := 0; FAutoIncrementColumn := -1; FEditingPrepared := False; end; if LastResult <> nil then begin Connection.Log(lcDebug, 'Result #'+IntToStr(NumResults)+' fetched.'); SetLength(FResultList, NumResults); FResultList[NumResults-1] := LastResult; FRecordCount := FRecordCount + LastResult.Count; end; if not AddResult then begin if HasResult then begin // FCurrentResults is normally done in SetRecNo, but never if result has no rows FCurrentResults := LastResult; NumFields := FConnection.Lib.sqlite3_column_count(LastResult.Statement); SetLength(FColumnTypes, NumFields); SetLength(FColumnLengths, NumFields); SetLength(FColumnFlags, NumFields); FColumnNames.Clear; FColumnOrgNames.Clear; StepResult := -1; for i:=0 to NumFields-1 do begin ColName := FConnection.DecodeAPIString(FConnection.Lib.sqlite3_column_name(LastResult.Statement, i)); FColumnNames.Add(ColName); ColOrgName := FConnection.DecodeAPIString(FConnection.Lib.sqlite3_column_origin_name(LastResult.Statement, i)); FColumnOrgNames.Add(ColOrgName); DataTypeStr := FConnection.DecodeAPIString(FConnection.Lib.sqlite3_column_decltype(LastResult.Statement, i)); if DataTypeStr.IsEmpty then begin if StepResult = -1 then StepResult := FConnection.Lib.sqlite3_step(LastResult.Statement); if StepResult = SQLITE_ROW then begin case FConnection.Lib.sqlite3_column_type(LastResult.Statement, i) of SQLITE_INTEGER: DataTypeStr := 'INTEGER'; SQLITE_FLOAT: DataTypeStr := 'FLOAT'; SQLITE_BLOB: DataTypeStr := 'BLOB'; SQLITE3_TEXT: DataTypeStr := 'TEXT'; // SQLITE_NULL gets "unknown" end; end else begin // No row available, fall back to TEXT DataTypeStr := 'TEXT'; end; end; FColumnTypes[i] := FConnection.GetDatatypeByName(DataTypeStr, False); end; if StepResult <> -1 then begin FConnection.Lib.sqlite3_reset(LastResult.Statement); end; FRecNo := -1; First; end else begin SetLength(FColumnTypes, 0); SetLength(FColumnLengths, 0); SetLength(FColumnFlags, 0); end; end; end; procedure TInterbaseQuery.Execute(AddResult: Boolean; UseRawResult: Integer); var i, j, NumFields, NumResults: Integer; TypeIndex: TDBDatatypeIndex; LastResult: TFDQuery; begin if UseRawResult = -1 then begin Connection.Query(FSQL, FStoreResult); UseRawResult := 0; end; if Connection.ResultCount > UseRawResult then begin LastResult := TInterbaseConnection(Connection).LastRawResults[UseRawResult] end else begin LastResult := nil; end; if AddResult and (Length(FResultList) = 0) then AddResult := False; if AddResult then NumResults := Length(FResultList)+1 else begin for i:=Low(FResultList) to High(FResultList) do begin FResultList[i].Free; end; NumResults := 1; FRecordCount := 0; FAutoIncrementColumn := -1; FEditingPrepared := False; end; if LastResult <> nil then begin Connection.Log(lcDebug, 'Result #'+IntToStr(NumResults)+' fetched.'); SetLength(FResultList, NumResults); FResultList[NumResults-1] := LastResult; FRecordCount := FRecordCount + LastResult.RecordCount; end; if not AddResult then begin if HasResult then begin // FCurrentResults is normally done in SetRecNo, but never if result has no rows FCurrentResults := LastResult; NumFields := LastResult.FieldCount; SetLength(FColumnTypes, NumFields); SetLength(FColumnLengths, NumFields); SetLength(FColumnFlags, NumFields); FColumnNames.Clear; FColumnOrgNames.Clear; for i:=0 to NumFields-1 do begin FColumnNames.Add(LastResult.Fields[i].FieldName); FColumnOrgNames.Add(FColumnNames[FColumnNames.Count-1]); case LastResult.Fields[i].DataType of ftSmallint, ftWord: TypeIndex := dbdtMediumInt; ftInteger: TypeIndex := dbdtInt; ftAutoInc: begin TypeIndex := dbdtInt; FAutoIncrementColumn := i; end; ftLargeint: TypeIndex := dbdtBigInt; ftBCD, ftFMTBcd: TypeIndex := dbdtDecimal; ftFixedChar, ftFixedWideChar: TypeIndex := dbdtChar; ftString, ftWideString, ftBoolean, ftGuid: TypeIndex := dbdtVarchar; ftMemo, ftWideMemo: TypeIndex := dbdtText; ftBlob, ftVariant: TypeIndex := dbdtMediumBlob; ftBytes: TypeIndex := dbdtBinary; ftVarBytes: TypeIndex := dbdtVarbinary; ftFloat, ftSingle: TypeIndex := dbdtFloat; ftDate: TypeIndex := dbdtDate; ftTime: TypeIndex := dbdtTime; ftDateTime, ftTimeStamp: TypeIndex := dbdtDateTime; else raise EDbError.CreateFmt(_('Unknown data type for column #%d - %s: %d'), [i, FColumnNames[i], Integer(LastResult.Fields[i].DataType)]); end; for j:=0 to High(FConnection.DataTypes) do begin if TypeIndex = FConnection.DataTypes[j].Index then FColumnTypes[i] := FConnection.DataTypes[j]; end; end; FRecNo := -1; First; end else begin SetLength(FColumnTypes, 0); SetLength(FColumnLengths, 0); SetLength(FColumnFlags, 0); end; end; end; procedure TDBQuery.SetColumnOrgNames(Value: TStringList); begin // Retrieve original column names from caller FColumnOrgNames.Text := Value.Text; end; procedure TDBQuery.SetDBObject(Value: TDBObject); begin // Assign values from outside to a new tdbobject FDBObject := TDBObject.Create(FConnection); FDBObject.Assign(Value); end; procedure TDBQuery.First; begin RecNo := 0; end; procedure TDBQuery.Next; begin RecNo := RecNo + 1; end; procedure TMySQLQuery.SetRecNo(Value: Int64); var LengthPointer: PLongInt; i, j: Integer; NumRows, WantedLocalRecNo: Int64; Row: TGridRow; RowFound: Boolean; begin if Value = FRecNo then Exit; if (not FEditingPrepared) and (Value >= RecordCount) then begin FRecNo := RecordCount; FEof := True; end else begin // Find row in edited data RowFound := False; if FEditingPrepared then begin for Row in FUpdateData do begin if Row.RecNo = Value then begin FCurrentRow := nil; FCurrentUpdateRow := Row; for i:=Low(FColumnLengths) to High(FColumnLengths) do FColumnLengths[i] := Length(FCurrentUpdateRow[i].NewText); RowFound := True; break; end; end; end; // Row not edited data - find it in normal result if not RowFound then begin NumRows := 0; for i:=Low(FResultList) to High(FResultList) do begin Inc(NumRows, FResultList[i].row_count); if NumRows > Value then begin FCurrentResults := FResultList[i]; // Do not seek if FCurrentRow points to the previous row of the wanted row WantedLocalRecNo := FCurrentResults.row_count-(NumRows-Value); if (WantedLocalRecNo = 0) or (FRecNo+1 <> Value) or (FCurrentRow = nil) then FConnection.Lib.mysql_data_seek(FCurrentResults, WantedLocalRecNo); FCurrentRow := FConnection.Lib.mysql_fetch_row(FCurrentResults); FCurrentUpdateRow := nil; // Remember length of column contents. Important for Col() so contents of cells with #0 chars are not cut off LengthPointer := FConnection.Lib.mysql_fetch_lengths(FCurrentResults); for j:=Low(FColumnLengths) to High(FColumnLengths) do FColumnLengths[j] := PInteger(Integer(LengthPointer) + j * SizeOf(Integer))^; break; end; end; end; FRecNo := Value; FEof := False; end; end; procedure TAdoDBQuery.SetRecNo(Value: Int64); var i, j: Integer; RowFound: Boolean; Row: TGridRow; NumRows, WantedLocalRecNo: Int64; begin if Value = FRecNo then Exit; if (not FEditingPrepared) and (Value >= RecordCount) then begin FRecNo := RecordCount; FEof := True; FCurrentResults.Last; end else begin // Find row in edited data RowFound := False; if FEditingPrepared then begin for Row in FUpdateData do begin if Row.RecNo = Value then begin FCurrentUpdateRow := Row; for i:=Low(FColumnLengths) to High(FColumnLengths) do FColumnLengths[i] := Length(FCurrentUpdateRow[i].NewText); RowFound := True; break; end; end; end; // Row not edited data - find it in normal result if not RowFound then begin NumRows := 0; try for i:=Low(FResultList) to High(FResultList) do begin Inc(NumRows, FResultList[i].RecordCount); if NumRows > Value then begin FCurrentResults := FResultList[i]; WantedLocalRecNo := FCurrentResults.RecordCount-(NumRows-Value); FCurrentResults.RecNo := WantedLocalRecNo+1; FCurrentUpdateRow := nil; for j:=Low(FColumnLengths) to High(FColumnLengths) do FColumnLengths[j] := FCurrentResults.Fields[j].DataSize; break; end; end; except // Catch broken connection on E:EOleException do begin FConnection.Active := False; FConnection.Log(lcError, E.Message); end; end; end; FRecNo := Value; FEof := False; end; end; procedure TPGQuery.SetRecNo(Value: Int64); var i, j: Integer; RowFound: Boolean; Row: TGridRow; NumRows: Int64; begin if Value = FRecNo then Exit; if (not FEditingPrepared) and (Value >= RecordCount) then begin FRecNo := RecordCount; FEof := True; end else begin // Find row in edited data RowFound := False; if FEditingPrepared then begin for Row in FUpdateData do begin if Row.RecNo = Value then begin FCurrentUpdateRow := Row; for i:=Low(FColumnLengths) to High(FColumnLengths) do FColumnLengths[i] := Length(FCurrentUpdateRow[i].NewText); RowFound := True; break; end; end; end; // Row not edited data - find it in normal result if not RowFound then begin NumRows := 0; for i:=Low(FResultList) to High(FResultList) do begin Inc(NumRows, FConnection.Lib.PQntuples(FResultList[i])); if NumRows > Value then begin FCurrentResults := FResultList[i]; FRecNoLocal := FConnection.Lib.PQntuples(FCurrentResults)-(NumRows-Value); FCurrentUpdateRow := nil; for j:=Low(FColumnLengths) to High(FColumnLengths) do FColumnLengths[j] := FConnection.Lib.PQgetlength(FCurrentResults, FRecNoLocal, j); break; end; end; end; FRecNo := Value; FEof := False; end; end; procedure TSQLiteQuery.SetRecNo(Value: Int64); var i: Integer; RowFound: Boolean; Row: TGridRow; NumRows: Int64; begin if Value = FRecNo then Exit; if (not FEditingPrepared) and (Value >= RecordCount) then begin FRecNo := RecordCount; FEof := True; end else begin // Find row in edited data RowFound := False; if FEditingPrepared then begin for Row in FUpdateData do begin if Row.RecNo = Value then begin FCurrentUpdateRow := Row; for i:=Low(FColumnLengths) to High(FColumnLengths) do FColumnLengths[i] := Length(FCurrentUpdateRow[i].NewText); RowFound := True; break; end; end; end; // Row not edited data - find it in normal result if not RowFound then begin NumRows := 0; for i:=Low(FResultList) to High(FResultList) do begin Inc(NumRows, FResultList[i].Count); if NumRows > Value then begin FCurrentResults := FResultList[i]; FRecNoLocal := FResultList[i].Count-(NumRows-Value); FCurrentUpdateRow := nil; //for j:=Low(FColumnLengths) to High(FColumnLengths) do // FColumnLengths[j] := FConnection.Lib.PQgetlength(FCurrentResults, FRecNoLocal, j); break; end; end; end; FRecNo := Value; FEof := False; end; end; procedure TInterbaseQuery.SetRecNo(Value: Int64); var i, j: Integer; RowFound: Boolean; Row: TGridRow; NumRows, WantedLocalRecNo: Int64; begin if Value = FRecNo then Exit; if (not FEditingPrepared) and (Value >= RecordCount) then begin FRecNo := RecordCount; FEof := True; FCurrentResults.Last; end else begin // Find row in edited data RowFound := False; if FEditingPrepared then begin for Row in FUpdateData do begin if Row.RecNo = Value then begin FCurrentUpdateRow := Row; for i:=Low(FColumnLengths) to High(FColumnLengths) do FColumnLengths[i] := Length(FCurrentUpdateRow[i].NewText); RowFound := True; break; end; end; end; // Row not edited data - find it in normal result if not RowFound then begin NumRows := 0; try for i:=Low(FResultList) to High(FResultList) do begin Inc(NumRows, FResultList[i].RecordCount); if NumRows > Value then begin FCurrentResults := FResultList[i]; WantedLocalRecNo := FCurrentResults.RecordCount-(NumRows-Value); FCurrentResults.RecNo := WantedLocalRecNo+1; FCurrentUpdateRow := nil; for j:=Low(FColumnLengths) to High(FColumnLengths) do FColumnLengths[j] := FCurrentResults.Fields[j].DataSize; break; end; end; except // Catch broken connection raise; end; end; FRecNo := Value; FEof := False; end; end; function TDBQuery.ColumnCount: Integer; begin if Assigned(FColumnNames) then Result := FColumnNames.Count else Result := -1; end; function TDBQuery.ColumnExists(Column: Integer): Boolean; begin // Check if given column exists in current row // Prevents crash when cancelling new row insertion Result := FConnection.Active and (Column > -1) and (Column < ColumnCount); if Result and FEditingPrepared and Assigned(FCurrentUpdateRow) then begin Result := FCurrentUpdateRow.Count > Column; end; end; function TDBQuery.GetColBinData(Column: Integer; var baData: TBytes): Boolean; begin Raise EDbError.Create(SNotImplemented); end; function TMySQLQuery.GetColBinData(Column: Integer; var baData: TBytes): Boolean; var AnsiStr: AnsiString; begin Result := False; if ColumnExists(Column) then begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then begin // Row was edited and only valid in a TGridRow AnsiStr := AnsiString(FCurrentUpdateRow[Column].NewText); end else begin // The normal case: Fetch cell from mysql result SetString(AnsiStr, FCurrentRow[Column], FColumnLengths[Column]); end; if Datatype(Column).Category in [dtcBinary, dtcSpatial] then begin SetLength(baData, Length(AnsiStr)); CopyMemory(baData, @AnsiStr[1], Length(AnsiStr)); Result := True; end; end; end; function TMySQLQuery.Col(Column: Integer; IgnoreErrors: Boolean=False): String; var AnsiStr: AnsiString; BitString: String; NumBit: Integer; ByteVal: Byte; c: Char; Field: PMYSQL_FIELD; begin if ColumnExists(Column) then begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then begin // Row was edited and only valid in a TGridRow Result := FCurrentUpdateRow[Column].NewText; end else begin // The normal case: Fetch cell from mysql result SetString(AnsiStr, FCurrentRow[Column], FColumnLengths[Column]); if Datatype(Column).Category in [dtcBinary, dtcSpatial] then Result := String(AnsiStr) else Result := Connection.DecodeAPIString(AnsiStr); // Create string bitmask for BIT fields if Datatype(Column).Index = dbdtBit then begin Field := FConnection.Lib.mysql_fetch_field_direct(FCurrentResults, column); // FConnection.Log(lcInfo, Field.name+': def: '+field.def+' length: '+inttostr(field.length)+' max_length: '+inttostr(field.max_length)+' decimals: '+inttostr(field.decimals)); for c in Result do begin ByteVal := Byte(c); BitString := ''; for NumBit:=0 to 7 do begin if (ByteVal shr NumBit and $1) = $1 then BitString := BitString + '1' else BitString := BitString + '0'; if Length(BitString) >= Field.length then break; end; if Length(BitString) >= Field.length then break; end; Result := ReverseString(BitString); end; end; end else if not IgnoreErrors then Raise EDbError.CreateFmt(_(MsgInvalidColumn), [Column, ColumnCount, RecordCount]); end; function TAdoDBQuery.Col(Column: Integer; IgnoreErrors: Boolean=False): String; begin if ColumnExists(Column) then begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then begin Result := FCurrentUpdateRow[Column].NewText; end else begin try case Datatype(Column).Category of dtcReal: Result := FloatToStr(FCurrentResults.Fields[Column].AsExtended, FFormatSettings); dtcTemporal: Result := FormatDateTime(Datatype(Column).Format, FCurrentResults.Fields[Column].AsFloat); else Result := FCurrentResults.Fields[Column].AsString; end; except Result := String(FCurrentResults.Fields[Column].AsAnsiString); end; if Datatype(Column).Index = dbdtBit then begin if UpperCase(Result) = 'TRUE' then Result := '1' else Result := '0'; end end; end else if not IgnoreErrors then Raise EDbError.CreateFmt(_(MsgInvalidColumn), [Column, ColumnCount, RecordCount]); end; function TPGQuery.Col(Column: Integer; IgnoreErrors: Boolean=False): String; var AnsiStr: AnsiString; begin if ColumnExists(Column) then begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then begin Result := FCurrentUpdateRow[Column].NewText; end else begin SetString(AnsiStr, FConnection.Lib.PQgetvalue(FCurrentResults, FRecNoLocal, Column), FColumnLengths[Column]); if Datatype(Column).Category in [dtcBinary, dtcSpatial] then Result := String(AnsiStr) else if Datatype(Column).Index = dbdtBool then if AnsiStr='t' then Result := 'true' else Result := 'false' else Result := Connection.DecodeAPIString(AnsiStr); end; end else if not IgnoreErrors then Raise EDbError.CreateFmt(_(MsgInvalidColumn), [Column, ColumnCount, RecordCount]); end; function TSQLiteQuery.Col(Column: Integer; IgnoreErrors: Boolean=False): String; begin if ColumnExists(Column) then begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then begin Result := FCurrentUpdateRow[Column].NewText; end else begin Result := FCurrentResults[FRecNoLocal][Column].OldText; end; end else if not IgnoreErrors then Raise EDbError.CreateFmt(_(MsgInvalidColumn), [Column, ColumnCount, RecordCount]); end; function TInterbaseQuery.Col(Column: Integer; IgnoreErrors: Boolean): String; begin if ColumnExists(Column) then begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then begin Result := FCurrentUpdateRow[Column].NewText; end else begin Result := FCurrentResults.Fields[Column].AsString; end; end else if not IgnoreErrors then Raise EDbError.CreateFmt(_(MsgInvalidColumn), [Column, ColumnCount, RecordCount]); end; function TDBQuery.Col(ColumnName: String; IgnoreErrors: Boolean=False): String; var idx: Integer; begin // ColumnNames is case insensitive, so we can select wrong cased columns in MariaDB 10.4 // See #599 idx := ColumnNames.IndexOf(ColumnName); if idx > -1 then Result := Col(idx) else if not IgnoreErrors then Raise EDbError.CreateFmt(_('Column "%s" not available.'), [ColumnName]); end; function TDBQuery.ColumnLengths(Column: Integer): Int64; begin Result := FColumnLengths[Column]; end; function TDBQuery.HexValue(Column: Integer; IgnoreErrors: Boolean=False): String; var baData: TBytes; begin // Return a binary column value as hex AnsiString if FConnection.Parameters.IsAnyMysql then begin GetColBinData(Column, baData); Result := HexValue(baData); end else Result := HexValue(Col(Column, IgnoreErrors)); end; function TDBQuery.HexValue(BinValue: String): String; var BinLen: Integer; Ansi: AnsiString; begin // Return a binary value as hex AnsiString Ansi := AnsiString(BinValue); BinLen := Length(Ansi); if BinLen = 0 then begin Result := Connection.EscapeString(''); end else begin if FConnection.IsHex(BinValue) then begin Result := BinValue; // Already hex encoded end else begin SetLength(Result, BinLen*2); BinToHex(PAnsiChar(Ansi), PChar(Result), BinLen); Result := '0x' + Result; end; if AppSettings.ReadBool(asLowercaseHex) then Result := Result.ToLowerInvariant; end; end; function TDBQuery.HexValue(var ByteData: TBytes): String; var BinLen: Integer; Ansi: AnsiString; begin BinLen := Length(ByteData); SetString(Ansi, PAnsiChar(ByteData), BinLen); if BinLen = 0 then begin Result := Connection.EscapeString(''); end else begin if FConnection.IsHex(String(Ansi)) then begin Result := String(Ansi); // Already hex encoded end else begin SetLength(Result, BinLen*2); BinToHex(PAnsiChar(Ansi), PChar(Result), BinLen); Result := '0x' + Result; end; if AppSettings.ReadBool(asLowercaseHex) then Result := Result.ToLowerInvariant; end; end; function TDBQuery.DataType(Column: Integer): TDBDataType; var Col: TTableColumn; begin Col := ColAttributes(Column); if Assigned(Col) then Result := Col.DataType else Result := FColumnTypes[Column]; end; function TDBQuery.MaxLength(Column: Integer): Int64; var ColAttr: TTableColumn; begin // Return maximum posible length of values in given columns // Note: PMYSQL_FIELD.max_length holds the maximum existing value in that column, which is useless here Result := MaxInt; ColAttr := ColAttributes(Column); if Assigned(ColAttr) then begin case ColAttr.DataType.Index of dbdtChar, dbdtVarchar, dbdtBinary, dbdtVarBinary, dbdtBit: Result := MakeInt(ColAttr.LengthSet); dbdtTinyText, dbdtTinyBlob: Result := 255; dbdtText, dbdtBlob: begin case FConnection.Parameters.NetTypeGroup of ngMySQL: Result := 65535; ngMSSQL: Result := MaxInt; ngPgSQL: Result := High(Int64); end; end; dbdtMediumText, dbdtMediumBlob: Result := 16777215; dbdtLongText, dbdtLongBlob: Result := 4294967295; end; end; end; function TDBQuery.ValueList(Column: Integer): TStringList; var ColAttr: TTableColumn; begin Result := TStringList.Create; Result.QuoteChar := ''''; Result.Delimiter := ','; ColAttr := ColAttributes(Column); if Assigned(ColAttr) then case ColAttr.DataType.Index of dbdtEnum, dbdtSet: Result.DelimitedText := ColAttr.LengthSet; dbdtBool: Result.DelimitedText := 'true,false'; end; end; function TDBQuery.ColAttributes(Column: Integer): TTableColumn; var i: Integer; begin Result := nil; if (Column < 0) or (Column >= FColumnOrgNames.Count) then raise EDbError.CreateFmt(_('Column #%s not available.'), [IntToStr(Column)]); if FColumns <> nil then begin for i:=0 to FColumns.Count-1 do begin if FColumns[i].Name = FColumnOrgNames[Column] then begin Result := FColumns[i]; break; end; end; end; end; function TDBQuery.ColExists(Column: String): Boolean; begin Result := (ColumnNames <> nil) and (ColumnNames.IndexOf(Column) > -1); end; function TMySQLQuery.ColIsPrimaryKeyPart(Column: Integer): Boolean; begin Result := (FColumnFlags[Column] and PRI_KEY_FLAG) = PRI_KEY_FLAG; end; function TAdoDBQuery.ColIsPrimaryKeyPart(Column: Integer): Boolean; begin // Result := FCurrentResults.Fields[0].KeyFields Result := False; end; function TPGQuery.ColIsPrimaryKeyPart(Column: Integer): Boolean; begin Result := False; end; function TSQLiteQuery.ColIsPrimaryKeyPart(Column: Integer): Boolean; var MetaResult: Integer; TableNm, ColumnNm: String; DataType, CollSeq: PAnsiChar; NotNull, PrimaryKey, Autoinc: Integer; begin Result := False; TableNm := TableName(Column); ColumnNm := FColumnOrgNames[Column]; if not TableNm.IsEmpty then begin MetaResult := FConnection.Lib.sqlite3_table_column_metadata(FConnection.FHandle, PAnsiChar(Utf8Encode(FConnection.Database)), PAnsiChar(Utf8Encode(TableNm)), PAnsiChar(Utf8Encode(ColumnNm)), DataType, CollSeq, NotNull, PrimaryKey, Autoinc ); if MetaResult <> SQLITE_ERROR then begin Result := PrimaryKey.ToBoolean; end; end; end; function TInterbaseQuery.ColIsPrimaryKeyPart(Column: Integer): Boolean; begin // Todo Result := False; end; function TMySQLQuery.ColIsUniqueKeyPart(Column: Integer): Boolean; begin Result := (FColumnFlags[Column] and UNIQUE_KEY_FLAG) = UNIQUE_KEY_FLAG; end; function TAdoDBQuery.ColIsUniqueKeyPart(Column: Integer): Boolean; begin Result := False; end; function TPGQuery.ColIsUniqueKeyPart(Column: Integer): Boolean; begin Result := False; end; function TSQLiteQuery.ColIsUniqueKeyPart(Column: Integer): Boolean; begin Result := False; end; function TInterbaseQuery.ColIsUniqueKeyPart(Column: Integer): Boolean; begin // Todo Result := False; end; function TMySQLQuery.ColIsKeyPart(Column: Integer): Boolean; begin Result := (FColumnFlags[Column] and MULTIPLE_KEY_FLAG) = MULTIPLE_KEY_FLAG; end; function TAdoDbQuery.ColIsKeyPart(Column: Integer): Boolean; begin Result := FCurrentResults.Fields[Column].IsIndexField; end; function TPGQuery.ColIsKeyPart(Column: Integer): Boolean; begin Result := False; end; function TSQLiteQuery.ColIsKeyPart(Column: Integer): Boolean; begin Result := False; end; function TInterbaseQuery.ColIsKeyPart(Column: Integer): Boolean; begin // Todo Result := False; end; function TDBQuery.ColIsVirtual(Column: Integer): Boolean; var Col: TTableColumn; begin Result := False; Col := ColAttributes(Column); if Col <> nil then begin Result := not Col.Virtuality.IsEmpty; end; end; function TMySQLQuery.IsNull(Column: Integer): Boolean; begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then Result := FCurrentUpdateRow[Column].NewIsNull else Result := FCurrentRow[Column] = nil; end; function TDBQuery.IsNull(Column: String): Boolean; var i, idx: Integer; begin idx := -1; for i:=0 to FColumnNames.Count-1 do begin if CompareText(Column, FColumnNames[i]) = 0 then begin idx := i; break; end; end; if idx > -1 then Result := IsNull(idx) else Result := True; end; function TAdoDBQuery.IsNull(Column: Integer): Boolean; begin Result := False; // Catch broken connection if FConnection.Active then begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then Result := FCurrentUpdateRow[Column].NewIsNull else begin try Result := FCurrentResults.Fields[Column].IsNull; except // Silence error: "Multiple-step operation generated errors. Check each status value." // @see #496 on E:EOleException do; end; end; end; end; function TPGQuery.IsNull(Column: Integer): Boolean; begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then Result := FCurrentUpdateRow[Column].NewIsNull else Result := FConnection.Lib.PQgetisnull(FCurrentResults, FRecNoLocal, Column) = 1; end; function TSQLiteQuery.IsNull(Column: Integer): Boolean; begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then Result := FCurrentUpdateRow[Column].NewIsNull else Result := FCurrentResults[FRecNoLocal][Column].OldIsNull; end; function TInterbaseQuery.IsNull(Column: Integer): Boolean; begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then Result := FCurrentUpdateRow[Column].NewIsNull else Result := FCurrentResults.Fields[Column].IsNull; end; function TDBQuery.IsFunction(Column: Integer): Boolean; begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then Result := FCurrentUpdateRow[Column].NewIsFunction else Result := False; end; function TMySQLQuery.HasResult: Boolean; begin Result := Length(FResultList) > 0; end; function TAdoDBQuery.HasResult: Boolean; begin Result := Length(FResultList) > 0; end; function TPGQuery.HasResult: Boolean; begin Result := Length(FResultList) > 0; end; function TSQLiteQuery.HasResult: Boolean; begin Result := Length(FResultList) > 0; end; function TInterbaseQuery.HasResult: Boolean; begin Result := Length(FResultList) > 0; end; procedure TDBQuery.PrepareColumnAttributes; var DB: String; DBObjects: TDBObjectList; LObj, Obj: TDBObject; begin // Try to fetch column names and keys // This is probably a VIEW, so column names need to be fetched differently Obj := nil; if FDBObject <> nil then Obj := FDBObject else begin DB := DatabaseName; if DB = '' then DB := Connection.Database; DBObjects := Connection.GetDBObjects(DB); for LObj in DBObjects do begin if (LObj.NodeType in [lntTable, lntView]) and Connection.IdentifierEquals(LObj.Name, TableName) then begin Obj := LObj; break; end; end; if Obj = nil then raise EDbError.Create(f_('Could not find table or view %s.%s. Please refresh database tree.', [DB, TableName])); end; // Obj.NodeType must be lntTable or lntView here, otherwise we get no columns or keys FColumns := Obj.TableColumns; FKeys := Obj.TableKeys; FForeignKeys := Obj.TableForeignKeys; end; procedure TDBQuery.PrepareEditing; begin // Try to fetch column names and keys and init update data if FEditingPrepared then Exit; PrepareColumnAttributes; FreeAndNil(FUpdateData); FUpdateData := TGridRows.Create; FEditingPrepared := True; end; procedure TDBQuery.DeleteRow; var sql: String; IsVirtual: Boolean; begin // Delete current row from result PrepareEditing; IsVirtual := Assigned(FCurrentUpdateRow) and FCurrentUpdateRow.Inserted; if not IsVirtual then begin sql := GridQuery('DELETE', 'FROM ' + QuotedDbAndTableName + ' WHERE ' + GetWhereClause); Connection.Query(sql); if Connection.RowsAffected = 0 then raise EDbError.Create(FormatNumber(Connection.RowsAffected)+' rows deleted when that should have been 1.'); end; if Assigned(FCurrentUpdateRow) then begin FUpdateData.Remove(FCurrentUpdateRow); FCurrentUpdateRow := nil; FRecNo := -1; end; end; function TDBQuery.InsertRow: Int64; var Row, OtherRow: TGridRow; c: TGridValue; i: Integer; ColAttr: TTableColumn; InUse: Boolean; begin // Add new row and return row number PrepareEditing; Row := TGridRow.Create(True); for i:=0 to ColumnCount-1 do begin c := TGridValue.Create; Row.Add(c); c.OldText := ''; c.OldIsFunction := False; c.OldIsNull := False; ColAttr := ColAttributes(i); if Assigned(ColAttr) then begin c.OldIsNull := ColAttr.DefaultType in [cdtNull, cdtAutoInc, cdtExpression]; if ColAttr.DefaultType in [cdtText] then c.OldText := FConnection.UnescapeString(ColAttr.DefaultText); end; c.NewText := c.OldText; c.NewIsFunction := c.OldIsFunction; c.NewIsNull := c.OldIsNull; c.Modified := False; end; Row.Inserted := True; // Find highest unused recno of inserted rows and use that for this row // Important: do not raise higher than what TVirtualStringTree.RootNodeCount can hold! Result := High(Cardinal); while True do begin InUse := False; for OtherRow in FUpdateData do begin InUse := OtherRow.RecNo = Result; if InUse then break; end; if not InUse then break; Dec(Result); end; Row.RecNo := Result; FUpdateData.Add(Row); end; procedure TDBQuery.SetCol(Column: Integer; NewText: String; Null: Boolean; IsFunction: Boolean); begin PrepareEditing; if not Assigned(FCurrentUpdateRow) then begin CreateUpdateRow; EnsureFullRow(False); end; FCurrentUpdateRow[Column].NewIsNull := Null; FCurrentUpdateRow[Column].NewIsFunction := IsFunction; FCurrentUpdateRow[Column].NewText := IfThen(Null, '', NewText); FCurrentUpdateRow[Column].Modified := (FCurrentUpdateRow[Column].NewText <> FCurrentUpdateRow[Column].OldText) or (FCurrentUpdateRow[Column].NewIsNull <> FCurrentUpdateRow[Column].OldIsNull) or (FCurrentUpdateRow[Column].NewIsFunction <> FCurrentUpdateRow[Column].OldIsFunction) ; // TODO: check if column allows NULL, otherwise force .Modified end; procedure TDBQuery.CreateUpdateRow; var i: Integer; c: TGridValue; Row: TGridRow; begin Row := TGridRow.Create(True); for i:=0 to ColumnCount-1 do begin c := TGridValue.Create; Row.Add(c); c.OldText := Col(i); c.NewText := c.OldText; c.OldIsNull := IsNull(i); c.NewIsNull := c.OldIsNull; c.OldIsFunction := False; c.NewIsFunction := c.OldIsFunction; c.Modified := False; end; Row.Inserted := False; Row.RecNo := RecNo; FCurrentUpdateRow := Row; FUpdateData.Add(FCurrentUpdateRow); end; function TDBQuery.EnsureFullRow(Refresh: Boolean): Boolean; var i: Integer; sql: String; Data: TDBQuery; begin // Load full column values Result := True; if Refresh or (not HasFullData) then try PrepareEditing; for i:=0 to FColumnOrgNames.Count-1 do begin if sql <> '' then sql := sql + ', '; sql := sql + Connection.QuoteIdent(FColumnOrgNames[i]); end; sql := sql + ' FROM '+QuotedDbAndTableName+' WHERE '+GetWhereClause; sql := GridQuery('SELECT', sql); Data := Connection.GetResults(sql); Result := Data.RecordCount = 1; if Result then begin if not Assigned(FCurrentUpdateRow) then CreateUpdateRow; for i:=0 to Data.ColumnCount-1 do begin FCurrentUpdateRow[i].OldText := Data.Col(i); FCurrentUpdateRow[i].NewText := FCurrentUpdateRow[i].OldText; FCurrentUpdateRow[i].OldIsNull := Data.IsNull(i); FCurrentUpdateRow[i].NewIsNull := FCurrentUpdateRow[i].OldIsNull; FCurrentUpdateRow[i].OldIsFunction := False; FCurrentUpdateRow[i].NewIsFunction := FCurrentUpdateRow[i].OldIsFunction; end; Data.Free; end; except on E:EDbError do Result := False; end; end; // Issue #1351 and https://www.heidisql.com/forum.php?t=39239 // Data view editor truncated for TEXT columns when emoji is present // Issue #1658: // Saving BLOB to file creates corrupted files function TDBQuery.HasFullData: Boolean; var i: Integer; P: PWideChar; NumChars: Integer; begin Result := True; if Assigned(FCurrentUpdateRow) then begin // In case we created a update-row we know for sure that we already loaded full contents Result := True; end else begin // This is done only once, before EnsureFullRow creates an update-row which returns true above. // Delphi/Length() counts bytes, while SQL/LEFT() counts characters. for i:=0 to ColumnCount-1 do begin //if TableName.Contains('test') then // FConnection.Log(lcInfo, 'HasFullData: '+ColumnNames[i]+' / '+ColumnOrgNames[i]); if FConnection.Parameters.IsAnyMySQL then begin if ColumnNames[i].StartsWith('LEFT', True) or ColumnNames[i].StartsWith('SUBSTR', True) then begin if Length(Col(i)) >= GRIDMAXDATA then begin Result := False; Break; end; end; end else begin // MS SQL does not provide the original column names with function calls like LEFT(..) NumChars := 0; P := PWideChar(Col(i)); while P <> '' do begin Inc(NumChars); if NumChars > GRIDMAXDATA then Break; P := CharNextW(P); end; Result := NumChars <> GRIDMAXDATA; end; end; end; end; function TDBQuery.SaveModifications: Boolean; var i: Integer; Row: TGridRow; Cell: TGridValue; sqlUpdate, sqlInsertColumns, sqlInsertValues, Val: String; RowModified: Boolean; ColAttr: TTableColumn; begin Result := True; if not FEditingPrepared then raise EDbError.Create(_('Internal error: Cannot post modifications before editing was prepared.')); for Row in FUpdateData do begin // Prepare update and insert queries RecNo := Row.RecNo; sqlUpdate := ''; sqlInsertColumns := ''; sqlInsertValues := ''; RowModified := False; for i:=0 to ColumnCount-1 do begin Cell := Row[i]; if not Cell.Modified then continue; RowModified := True; if sqlUpdate <> '' then begin sqlUpdate := sqlUpdate + ', '; sqlInsertColumns := sqlInsertColumns + ', '; sqlInsertValues := sqlInsertValues + ', '; end; if Cell.NewIsNull then Val := 'NULL' else if Cell.NewIsFunction then Val := Cell.NewText else case Datatype(i).Category of dtcInteger, dtcReal: begin Val := Connection.EscapeString(Cell.NewText); if (Datatype(i).Index = dbdtBit) and FConnection.Parameters.IsAnyMySQL then Val := 'b' + Val; end; dtcBinary, dtcSpatial: Val := HexValue(Cell.NewText); else begin if Datatype(i).Index in [dbdtNchar, dbdtNvarchar, dbdtNtext] then Val := 'N' + Connection.EscapeString(Cell.NewText) else if Datatype(i).Category = dtcTemporal then Val := Connection.EscapeString(Connection.GetDateTimeValue(Cell.NewText, Datatype(i).Index)) else Val := Connection.EscapeString(Cell.NewText); end; end; sqlUpdate := sqlUpdate + Connection.QuoteIdent(FColumnOrgNames[i]) + '=' + Val; sqlInsertColumns := sqlInsertColumns + Connection.QuoteIdent(FColumnOrgNames[i]); sqlInsertValues := sqlInsertValues + Val; end; // Post query and fetch just inserted auto-increment id if applicable if RowModified then try if Row.Inserted then begin Connection.Query('INSERT INTO '+QuotedDbAndTableName+' ('+sqlInsertColumns+') VALUES ('+sqlInsertValues+')'); for i:=0 to ColumnCount-1 do begin ColAttr := ColAttributes(i); if Assigned(ColAttr) and (ColAttr.DefaultType = cdtAutoInc) then begin Row[i].NewText := UnformatNumber(Row[i].NewText); if Row[i].NewText = '0' then Row[i].NewText := Connection.GetVar('SELECT LAST_INSERT_ID()'); Row[i].NewIsNull := False; break; end; end; end else begin sqlUpdate := QuotedDbAndTableName+' SET '+sqlUpdate+' WHERE '+GetWhereClause; sqlUpdate := GridQuery('UPDATE', sqlUpdate); Connection.Query(sqlUpdate); if Connection.RowsAffected = 0 then begin raise EDbError.Create(FormatNumber(Connection.RowsAffected)+' rows updated when that should have been 1.'); Result := False; end; end; // Reset modification flags for i:=0 to ColumnCount-1 do begin Cell := Row[i]; Cell.OldText := Cell.NewText; Cell.OldIsNull := Cell.NewIsNull; Cell.OldIsFunction := False; Cell.NewIsFunction := False; Cell.Modified := False; end; Row.Inserted := False; // Reload real row data from server if keys allow that EnsureFullRow(True); except on E:EDbError do begin Result := False; ErrorDialog(E.Message); end; end; end; end; procedure TDBQuery.DiscardModifications; var x: Integer; c: TGridValue; begin if FEditingPrepared and Assigned(FCurrentUpdateRow) then begin if FCurrentUpdateRow.Inserted then begin FUpdateData.Remove(FCurrentUpdateRow); FRecNo := -1; end else for x:=0 to FCurrentUpdateRow.Count-1 do begin c := FCurrentUpdateRow[x]; c.NewText := c.OldText; c.NewIsNull := c.OldIsNull; c.NewIsFunction := c.OldIsFunction; c.Modified := False; end; end; end; function TDBQuery.Modified(Column: Integer): Boolean; begin Result := False; if FEditingPrepared and Assigned(FCurrentUpdateRow) then try Result := FCurrentUpdateRow[Column].Modified; except connection.Log(lcdebug, inttostr(column)); raise; end; end; function TDBQuery.Modified: Boolean; var x, y: Integer; begin Result := False; if FEditingPrepared then for y:=0 to FUpdateData.Count-1 do begin for x:=0 to FUpdateData[y].Count-1 do begin Result := FUpdateData[y][x].Modified; if Result then break; end; if Result then break; end; end; function TDBQuery.Inserted: Boolean; begin // Check if current row was inserted and not yet posted to the server Result := False; if FEditingPrepared and Assigned(FCurrentUpdateRow) then Result := FCurrentUpdateRow.Inserted; end; function TMySQLQuery.DatabaseName: String; var Field: PMYSQL_FIELD; i: Integer; begin // Find and return name of database of current query if FDBObject <> nil then begin Result := FDBObject.Database; end else begin // Return first available Field.db property, or just the current database as fallback. // For a view in db1 selecting from db2, this returns db2, which triggers errors in GetCreateViewCode! for i:=0 to ColumnCount-1 do begin Field := FConnection.Lib.mysql_fetch_field_direct(FCurrentResults, i); if Field.db <> '' then begin Result := Connection.DecodeAPIString(Field.db); break; end; end; if Result = '' then Result := Connection.Database; end; end; function TAdoDBQuery.DatabaseName: String; begin Result := Connection.Database; end; function TPGQuery.DatabaseName: String; begin // TODO Result := Connection.Database; end; function TSQLiteQuery.DatabaseName: String; begin // TODO Result := Connection.Database; end; function TInterbaseQuery.DatabaseName: String; begin // Todo Result := Connection.Database; end; function TDBQuery.TableName: String; var i: Integer; NextTable: String; rx: TRegExpr; begin // Get table name from a result set Result := ''; for i:=0 to ColumnCount-1 do begin NextTable := TableName(i); if (not Result.IsEmpty) and (not NextTable.IsEmpty) and (Result <> NextTable) then raise EDbError.Create(_('More than one table involved.')); if not NextTable.IsEmpty then Result := NextTable; end; if Result.IsEmpty then begin // Untested with joins, compute columns and views Result := GetTableNameFromSQLEx(SQL, idMixCase); rx := TRegExpr.Create; rx.Expression := '\.([^\.]+)$'; if rx.Exec(Result) then Result := rx.Match[1]; rx.Free; if Result.IsEmpty then raise EDbError.Create('Could not determine name of table.'); end; end; function TMySQLQuery.TableName(Column: Integer): String; var Field: PMYSQL_FIELD; tbl: AnsiString; Objects: TDBObjectList; Obj: TDBObject; begin Field := FConnection.Lib.mysql_fetch_field_direct(FCurrentResults, Column); if Field.table^ <> Field.org_table^ then begin // Probably a VIEW, in which case we rely on the first column's table name. // TODO: This is unsafe when joining a view with a table/view. if Field.db <> '' then begin Objects := Connection.GetDBObjects(Connection.DecodeAPIString(Field.db)); for Obj in Objects do begin if (Obj.Name = Connection.DecodeAPIString(Field.table)) and (Obj.NodeType = lntView) then begin tbl := Field.table; break; end; end; end; end else begin // Normal table column // Note: this is empty on data tab TEXT columns with LEFT(..) clause tbl := Field.org_table; end; Result := Connection.DecodeAPIString(tbl); end; function TAdoDBQuery.TableName(Column: Integer): String; begin Result := ''; end; function TPGQuery.TableName(Column: Integer): String; var FieldTypeOID: POid; begin // Get table name from a result set // "123::regclass" results are quoted if they contain special characters Result := EmptyStr; FieldTypeOID := FConnection.Lib.PQftable(FCurrentResults, Column); if not FConnection.RegClasses.ContainsKey(FieldTypeOID) then begin Result := FConnection.GetVar('SELECT '+IntToStr(FieldTypeOID)+'::regclass'); Result := FConnection.DeQuoteIdent(Result); FConnection.RegClasses.Add(FieldTypeOID, Result); end else begin FConnection.RegClasses.TryGetValue(FieldTypeOID, Result); end; end; function TSQLiteQuery.TableName(Column: Integer): String; var tblA: AnsiString; begin Result := EmptyStr; tblA := FConnection.Lib.sqlite3_column_table_name(FCurrentResults.Statement, Column); Result := FConnection.DecodeAPIString(tblA); end; function TInterbaseQuery.TableName(Column: Integer): String; begin // Todo end; function TDBQuery.QuotedDbAndTableName: String; begin // Prefer TDBObject when quoting as it knows its schema if FDBObject <> nil then Result := FDBObject.QuotedDbAndTableName else Result := FConnection.QuotedDbAndTableName(DatabaseName, TableName); end; function TDBQuery.GetKeyColumns: TStringList; var i: Integer; begin // Return key column names, or all column names if no good key present PrepareEditing; Result := Connection.GetKeyColumns(FColumns, FKeys); if Result.Count = 0 then begin // No good key found. Just expect all columns to be present. for i:=0 to FColumns.Count-1 do Result.Add(FColumns[i].Name); end; end; procedure TDBQuery.CheckEditable; var i: Integer; KeyCols: TStringList; begin KeyCols := GetKeyColumns; if KeyCols.Count = 0 then raise EDbError.Create(_(MSG_NOGRIDEDITING)); // All column names must be present in order to send valid INSERT/UPDATE/DELETE queries for i:=0 to KeyCols.Count-1 do begin if FColumnOrgNames.IndexOf(KeyCols[i]) = -1 then raise EDbError.Create(_(MSG_NOGRIDEDITING)); end; for i:=0 to FColumnOrgNames.Count-1 do begin if FColumnOrgNames[i] = '' then raise EDbError.CreateFmt(_('Column #%d has an undefined origin: %s'), [i, ColumnNames[i]]); end; end; function TDBQuery.IsEditable: Boolean; begin try CheckEditable; Result := True; except on E:EDbError do begin FConnection.Log(lcDebug, E.Message); Result := False; end; end; end; function TDBQuery.GetWhereClause: String; var i, j: Integer; NeededCols: TStringList; ColVal: String; ColIsNull: Boolean; begin // Compose WHERE clause including values from best key for editing NeededCols := GetKeyColumns; Result := ''; for i:=0 to NeededCols.Count-1 do begin j := FColumnOrgNames.IndexOf(NeededCols[i]); if j = -1 then raise EDbError.CreateFmt(_('Cannot compose WHERE clause - column missing: %s'), [NeededCols[i]]); if Result <> '' then Result := Result + ' AND'; Result := Result + ' ' + Connection.QuoteIdent(FColumnOrgNames[j]); if (DataType(j).Index = dbdtJson) and (Self is TPGQuery) then begin Result := Result + '::text'; end; if Modified(j) then begin ColVal := FCurrentUpdateRow[j].OldText; ColIsNull := FCurrentUpdateRow[j].OldIsNull; end else begin ColVal := Col(j); ColIsNull := IsNull(j); end; if ColIsNull then Result := Result + ' IS NULL' else begin case DataType(j).Category of dtcInteger, dtcReal: begin if DataType(j).Index = dbdtBit then Result := Result + '=b' + Connection.EscapeString(ColVal) else begin // Guess (!) the default value silently inserted by the server. This is likely // to be incomplete in cases where a UNIQUE key allows NULL here if ColVal='' then ColVal := '0'; Result := Result + '=' + ColVal; end; end; dtcTemporal: Result := Result + '=' + Connection.EscapeString(Connection.GetDateTimeValue(ColVal, DataType(j).Index)); dtcBinary, dtcSpatial: Result := Result + '=' + HexValue(ColVal); else begin // Any other data type goes here, including text: case DataType(j).Index of // Support international characters with N-prefix on MSSQL, see #1115: dbdtNchar, dbdtNvarchar, dbdtNtext: Result := Result + '=N' + Connection.EscapeString(ColVal); else Result := Result + '=' + Connection.EscapeString(ColVal); end; end; end; end; end; end; function TDBQuery.GridQuery(QueryType, QueryBody: String): String; var KeyColumns: TStringList; begin // Return automatic grid UPDATE/DELETE/SELECT, and apply LIMIT clause if no good key is present KeyColumns := Connection.GetKeyColumns(FColumns, FKeys); if KeyColumns.Count > 0 then Result := QueryType + ' ' + QueryBody else Result := Connection.ApplyLimitClause(QueryType, QueryBody, 1, 0); end; { TGridValue } destructor TGridValue.Destroy; begin NewText := ''; OldText := ''; inherited; end; { TSQLiteGridRows } constructor TSQLiteGridRows.Create(AOwner: TSQLiteConnection); begin inherited Create; FConnection := AOwner; end; destructor TSQLiteGridRows.Destroy; begin try if Statement <> nil then FConnection.Lib.sqlite3_finalize(Statement); except on E:Exception do; end; inherited; end; { TDBObjectComparer } function TDBObjectComparer.Compare(const Left, Right: TDBObject): Integer; begin // Simple sort method for a TDBObjectList Result := CompareAnyNode(Left.Schema+'.'+Left.Name, Right.Schema+'.'+Right.Name); end; function TDBObjectDropComparer.Compare(const Left, Right: TDBObject): Integer; begin // Sorting a TDBObject items so that dropping them does not trap in SQL errors if (Left.NodeType = lntTrigger) and (Right.NodeType <> lntTrigger) then Result := -1 else if (Left.NodeType <> lntTrigger) and (Right.NodeType = lntTrigger) then Result := 1 else if (Left.NodeType = lntView) and (Right.NodeType <> lntView) then Result := -1 else if (Left.NodeType <> lntView) and (Right.NodeType = lntView) then Result := 1 else Result := 0; end; { TDBObject } constructor TDBObject.Create(OwnerConnection: TDBConnection); begin NodeType := lntNone; Name := ''; Database := ''; Schema := ''; Rows := -1; Size := -1; Created := 0; Updated := 0; Engine := ''; Comment := ''; Version := -1; AutoInc := -1; RowFormat := ''; AvgRowLen := -1; MaxDataLen := -1; IndexLen := -1; DataLen := -1; DataFree := -1; LastChecked := 0; Collation := ''; CheckSum := -1; CreateOptions := ''; FCreateCode := ''; FCreateCodeLoaded := False; FConnection := OwnerConnection; end; procedure TDBObject.Assign(Source: TPersistent); var s: TDBObject; begin if Source is TDBObject then begin s := Source as TDBObject; Name := s.Name; Column := s.Column; Collation := s.Collation; Engine := s.Engine; Schema := s.Schema; Database := s.Database; NodeType := s.NodeType; GroupType := s.GroupType; Created := s.Created; Updated := s.Updated; Comment := s.Comment; Rows := s.Rows; Size := s.Size; ArgTypes := s.ArgTypes; FCreateCode := s.FCreateCode; FCreateCodeLoaded := s.FCreateCodeLoaded; end else inherited; end; procedure TDBObject.UnloadDetails; begin if FConnection.FColumnCache.ContainsKey(QuotedDbAndTableName) then FConnection.FColumnCache.Remove(QuotedDbAndTableName); if FConnection.FKeyCache.ContainsKey(QuotedDbAndTableName) then FConnection.FKeyCache.Remove(QuotedDbAndTableName); if FConnection.FForeignKeyCache.ContainsKey(QuotedDbAndTableName) then FConnection.FForeignKeyCache.Remove(QuotedDbAndTableName); if FConnection.FCheckConstraintCache.ContainsKey(QuotedDbAndTableName) then FConnection.FCheckConstraintCache.Remove(QuotedDbAndTableName); FCreateCode := ''; FCreateCodeLoaded := False; end; function TDBObject.IsSameAs(CompareTo: TDBObject): Boolean; begin if (not Assigned(CompareTo)) or (CompareTo = nil) then begin Result := False; end else begin try Result := FConnection.IdentifierEquals(Name, CompareTo.Name) and (NodeType = CompareTo.NodeType) and (Database = CompareTo.Database) and (Schema = CompareTo.Schema) and (Column = CompareTo.Column) and (ArgTypes = CompareTo.ArgTypes) and (Connection = CompareTo.Connection); except // No reproduction recipe yet, but numerous crashes from above were reported on E:EAccessViolation do Result := False; end; end; end; function TDBObject.GetObjType: String; begin case NodeType of lntTable: Result := 'Table'; lntView: Result := 'View'; lntFunction: Result := 'Function'; lntProcedure: Result := 'Procedure'; lntTrigger: Result := 'Trigger'; lntEvent: Result := 'Event'; lntColumn: Result := 'Column'; else Result := _('Unknown, should never appear'); end; end; function TDBObject.GetImageIndex: Integer; begin // Detect key icon index for specified db object (table, trigger, ...) case NodeType of lntNone: begin // Prevent AV with no connection if FConnection <> nil then Result := FConnection.Parameters.ImageIndex else Result := -1; end; lntDb: Result := ICONINDEX_DB; lntGroup: begin case GroupType of lntTable: Result := ICONINDEX_TABLE; lntFunction: Result := ICONINDEX_STOREDFUNCTION; lntProcedure: Result := ICONINDEX_STOREDPROCEDURE; lntView: Result := ICONINDEX_VIEW; lntTrigger: Result := ICONINDEX_TRIGGER; lntEvent: Result := ICONINDEX_EVENT; else Result := -1; end; end; lntTable: Result := ICONINDEX_TABLE; lntFunction: Result := ICONINDEX_STOREDFUNCTION; lntProcedure: Result := ICONINDEX_STOREDPROCEDURE; lntView: Result := ICONINDEX_VIEW; lntTrigger: Result := ICONINDEX_TRIGGER; lntEvent: Result := ICONINDEX_EVENT; lntColumn: Result := ICONINDEX_FIELD; else Result := -1; end; end; function TDBObject.GetOverlayImageIndex: Integer; var EngineUpper: String; begin // Detect small overlay icon index for specified table engine Result := -1; case NodeType of lntNone: begin if not Connection.Active then Result := 158; end; lntDb: begin if Database = Connection.Database then Result := ICONINDEX_HIGHLIGHTMARKER; end; lntTable: begin EngineUpper := UpperCase(Engine); if EngineUpper = 'FEDERATED' then Result := 177 else if EngineUpper = 'MEMORY' then Result := 178 else if EngineUpper = 'ARIA' then Result := 179 else if EngineUpper = 'CSV' then Result := 180 else if EngineUpper = 'PERFORMANCE_SCHEMA' then Result := 181 else if EngineUpper = 'BLACKHOLE' then Result := 167 else if EngineUpper = 'MRG_MYISAM' then Result := 182; end; end; end; function TDBObject.GetPath: String; begin Result := Database + DELIM + Schema + DELIM + Name; end; function TDBObject.GetCreateCode: String; begin if not FCreateCodeLoaded then try FCreateCode := Connection.GetCreateCode(Self); FCreateCodeLoaded := True; except on E:Exception do Connection.Log(lcError, E.Message); end; Result := FCreateCode; end; function TDBObject.GetCreateCode(RemoveAutoInc, RemoveDefiner: Boolean): String; procedure RemovePattern(RegExp: String); var rx: TRegExpr; begin // Remove first occurrence of pattern from result rx := TRegExpr.Create; rx.Expression := RegExp; rx.ModifierI := True; if rx.Exec(Result) then begin Delete(Result, rx.MatchPos[0], rx.MatchLen[0]-1); end; rx.Free; end; begin Result := GetCreateCode; if RemoveAutoInc then begin // Remove AUTO_INCREMENT clause RemovePattern('\sAUTO_INCREMENT\s*\=\s*\d+\s'); end; if RemoveDefiner then begin // Remove DEFINER clause RemovePattern('\sDEFINER\s*\=\s*\S+\s'); end; end; function TDBObject.QuotedDatabase(AlwaysQuote: Boolean=True): String; begin if FConnection.Parameters.NetTypeGroup = ngPgSQL then Result := Connection.QuoteIdent(Schema, AlwaysQuote) else Result := Connection.QuoteIdent(Database, AlwaysQuote); end; function TDBObject.QuotedName(AlwaysQuote: Boolean=True; SeparateSegments: Boolean=True): String; begin Result := ''; if FConnection.Parameters.IsAnyMSSQL then begin // MSSQL expects schema separated from table, and in some situations the whole string quoted as a whole if Schema <> '' then begin if SeparateSegments then Result := Result + Connection.QuoteIdent(Schema, AlwaysQuote) else Result := Result + Schema; end; Result := Result + '.'; if SeparateSegments then Result := Result + Connection.QuoteIdent(Name, AlwaysQuote) else Result := Connection.QuoteIdent(Result + Name, AlwaysQuote); end else begin Result := Result + Connection.QuoteIdent(Name, AlwaysQuote); end; end; function TDBObject.QuotedDbAndTableName(AlwaysQuote: Boolean=True): String; begin // Used in data grid query, exclude database in Interbase mode if FConnection.Parameters.IsAnyInterbase then Result := QuotedName(AlwaysQuote) else Result := QuotedDatabase(AlwaysQuote) + '.' + QuotedName(AlwaysQuote); end; function TDBObject.QuotedColumn(AlwaysQuote: Boolean=True): String; begin Result := Connection.QuoteIdent(Column, AlwaysQuote); end; // Return fitting schema clause for queries in IS.TABLES, IS.ROUTINES etc. // TODO: Does not work on MSSQL 2000 function TDBObject.SchemaClauseIS(Prefix: String): String; begin if Schema <> '' then Result := Prefix+'_SCHEMA' + '=' + Connection.EscapeString(Schema) else Result := Connection.GetSQLSpecifity(spISSchemaCol, [Prefix]) + '=' + Connection.EscapeString(Database); end; function TDBObject.RowCount(Reload: Boolean): Int64; begin if (Rows = -1) or Reload then begin Rows := Connection.GetRowCount(Self); end; Result := Rows; end; procedure TDBObject.Drop; begin Connection.Drop(Self); end; function TDBObject.GetTableColumns: TTableColumnList; var ColumnsInCache: TTableColumnList; begin // Return columns from table object if not FConnection.FColumnCache.ContainsKey(QuotedDbAndTableName) then begin FConnection.FColumnCache.AddOrSetValue(QuotedDbAndTableName, Connection.GetTableColumns(Self)); end; FConnection.FColumnCache.TryGetValue(QuotedDbAndTableName, ColumnsInCache); Result := TTableColumnList.Create; Result.Assign(ColumnsInCache); end; function TDBObject.GetTableKeys: TTableKeyList; var KeysInCache: TTableKeyList; begin // Return keys from table object if not FConnection.FKeyCache.ContainsKey(QuotedDbAndTableName) then begin FConnection.FKeyCache.AddOrSetValue(QuotedDbAndTableName, Connection.GetTableKeys(Self)); end; FConnection.FKeyCache.TryGetValue(QuotedDbAndTableName, KeysInCache); Result := TTableKeyList.Create; Result.Assign(KeysInCache); end; function TDBObject.GetTableForeignKeys: TForeignKeyList; var ForeignKeysInCache: TForeignKeyList; begin // Return foreign keys from table object if not FConnection.FForeignKeyCache.ContainsKey(QuotedDbAndTableName) then begin FConnection.FForeignKeyCache.AddOrSetValue(QuotedDbAndTableName, Connection.GetTableForeignKeys(Self)); end; FConnection.FForeignKeyCache.TryGetValue(QuotedDbAndTableName, ForeignKeysInCache); Result := TForeignKeyList.Create; Result.Assign(ForeignKeysInCache); end; function TDBObject.GetTableCheckConstraints: TCheckConstraintList; var CheckConstraintsInCache: TCheckConstraintList; begin // Return check constraint from table object if not FConnection.CheckConstraintCache.ContainsKey(QuotedDbAndTableName) then begin FConnection.CheckConstraintCache.AddOrSetValue(QuotedDbAndTableName, Connection.GetTableCheckConstraints(Self)); end; FConnection.CheckConstraintCache.TryGetValue(QuotedDbAndTableName, CheckConstraintsInCache); Result := TCheckConstraintList.Create; Result.Assign(CheckConstraintsInCache); end; { *** TTableColumn } constructor TTableColumn.Create(AOwner: TDBConnection; Serialized: String=''); var Attributes: TStringList; DataTypeIdx, OldDataTypeIdx: TDBDatatypeIndex; i: Integer; NumVal: String; function FromSerialized(Name, Default: String): String; begin Result := Attributes.Values[Name]; if Result.IsEmpty then Result := Default; end; begin // Initialize column from serialized values or use defaults inherited Create; FConnection := AOwner; // Prepare serialized string Serialized := StringReplace(Serialized, CHR13REPLACEMENT, #13, [rfReplaceAll]); Serialized := StringReplace(Serialized, CHR10REPLACEMENT, #10, [rfReplaceAll]); Attributes := Explode(DELIMITER, Serialized); // Apply given or default attributes Name := FromSerialized('Name', ''); OldName := FromSerialized('OldName', ''); NumVal := FromSerialized('DataType', Integer(dbdtUnknown).ToString); DataTypeIdx := TDBDatatypeIndex(NumVal.ToInteger); NumVal := FromSerialized('OldDataType', Integer(dbdtUnknown).ToString); OldDataTypeIdx := TDBDatatypeIndex(NumVal.ToInteger); for i:=Low(Connection.Datatypes) to High(Connection.Datatypes) do begin if Connection.Datatypes[i].Index = DataTypeIdx then DataType := Connection.Datatypes[i]; if Connection.Datatypes[i].Index = OldDataTypeIdx then OldDataType := Connection.Datatypes[i]; end; LengthSet := FromSerialized('LengthSet', ''); Unsigned := FromSerialized('Unsigned', '0').ToInteger.ToBoolean; AllowNull := FromSerialized('AllowNull', '1').ToInteger.ToBoolean; ZeroFill := FromSerialized('ZeroFill', '0').ToInteger.ToBoolean; LengthCustomized := FromSerialized('LengthCustomized', '0').ToInteger.ToBoolean; NumVal := FromSerialized('DefaultType', Integer(cdtNothing).ToString); DefaultType := TColumnDefaultType(NumVal.ToInteger); DefaultText := FromSerialized('DefaultText', ''); NumVal := FromSerialized('OnUpdateType', Integer(cdtNothing).ToString); OnUpdateType := TColumnDefaultType(NumVal.ToInteger); OnUpdateText := FromSerialized('OnUpdateText', ''); Comment := FromSerialized('Comment', ''); Charset := FromSerialized('Charset', ''); Collation := FromSerialized('Collation', ''); GenerationExpression := FromSerialized('Expression', ''); Virtuality := FromSerialized('Virtuality', ''); NumVal := FromSerialized('Status', Integer(esUntouched).ToString); FStatus := TEditingStatus(NumVal.ToInteger); Attributes.Free; end; destructor TTableColumn.Destroy; begin inherited Destroy; end; procedure TTableColumn.Assign(Source: TPersistent); var s: TTableColumn; begin if Source is TTableColumn then begin s := Source as TTableColumn; Name := s.Name; OldName := s.OldName; DataType := s.DataType; OldDataType := s.OldDataType; LengthSet := s.LengthSet; Unsigned := s.Unsigned; AllowNull := s.AllowNull; ZeroFill := s.ZeroFill; LengthCustomized := s.LengthCustomized; DefaultType := s.DefaultType; DefaultText := s.DefaultText; OnUpdateType := s.OnUpdateType; OnUpdateText := s.OnUpdateText; Comment := s.Comment; Charset := s.Charset; Collation := s.Collation; GenerationExpression := s.GenerationExpression; Virtuality := s.Virtuality; FStatus := s.FStatus; end else inherited; end; function TTableColumn.Serialize: String; var s: TStringList; begin // Return object attributes/fields in a one-line text format, which can later be // restored through passing that text to the constructor // We could also use the .SQLCode method to get a text representation, but that // would require a more complex deserializing method s := TStringList.Create; s.AddPair('Name', Name); s.AddPair('OldName', OldName); s.AddPair('DataType', Integer(DataType.Index).ToString); s.AddPair('OldDataType', Integer(OldDataType.Index).ToString); s.AddPair('LengthSet', LengthSet); s.AddPair('Unsigned', Unsigned.ToInteger.ToString); s.AddPair('AllowNull', AllowNull.ToInteger.ToString); s.AddPair('ZeroFill', ZeroFill.ToInteger.ToString); s.AddPair('LengthCustomized', LengthCustomized.ToInteger.ToString); s.AddPair('DefaultType', Integer(DefaultType).ToString); s.AddPair('DefaultText', DefaultText); s.AddPair('OnUpdateType', Integer(OnUpdateType).ToString); s.AddPair('OnUpdateText', OnUpdateText); s.AddPair('Comment', Comment); s.AddPair('Charset', Charset); s.AddPair('Collation', Collation); s.AddPair('GenerationExpression', GenerationExpression); s.AddPair('Virtuality', Virtuality); s.AddPair('Status', Integer(FStatus).ToString); Result := Implode(DELIMITER, s); s.Free; Result := StringReplace(Result, #13, CHR13REPLACEMENT, [rfReplaceAll]); Result := StringReplace(Result, #10, CHR10REPLACEMENT, [rfReplaceAll]); end; procedure TTableColumn.SetStatus(Value: TEditingStatus); begin // Set editing flag and enable "Save" button if (FStatus in [esAddedUntouched, esAddedModified]) and (Value = esModified) then Value := esAddedModified else if (FStatus in [esAddedUntouched, esAddedModified]) and (Value = esDeleted) then Value := esAddedDeleted; FStatus := Value; end; function TTableColumn.SQLCode(OverrideCollation: String=''; Parts: TColumnParts=[cpAll]): String; var IsVirtual: Boolean; function InParts(Part: TColumnPart): Boolean; begin Result := (Part in Parts) or (cpAll in Parts); end; begin Result := ''; IsVirtual := (GenerationExpression <> '') and (Virtuality <> ''); if InParts(cpName) then begin Result := Result + FConnection.QuoteIdent(Name) + ' '; end; if InParts(cpType) then begin Result := Result + DataType.Name; if (LengthSet <> '') and DataType.HasLength then Result := Result + '(' + LengthSet + ')'; if (DataType.Category in [dtcInteger, dtcReal]) and Unsigned then Result := Result + ' UNSIGNED'; if (DataType.Category in [dtcInteger, dtcReal]) and ZeroFill then Result := Result + ' ZEROFILL'; Result := Result + ' '; // Add space after each part end; if InParts(cpAllowNull) and (not IsVirtual) then begin if not AllowNull then Result := Result + 'NOT NULL ' else if not FConnection.Parameters.IsAnyInterbase then Result := Result + 'NULL '; end; if InParts(cpDefault) and (not IsVirtual) then begin if DefaultType <> cdtNothing then begin case DefaultType of // cdtNothing: leave out whole clause cdtText: Result := Result + 'DEFAULT '+FConnection.EscapeString(DefaultText); cdtNull: Result := Result + 'DEFAULT NULL'; cdtAutoInc: Result := Result + 'AUTO_INCREMENT'; cdtExpression: Result := Result + 'DEFAULT '+DefaultText; end; case OnUpdateType of // cdtNothing: leave out whole clause // cdtText: not supported, but may be valid in MariaDB? // cdtNull: not supported, but may be valid in MariaDB? // cdtAutoInc: not valid in ON UPDATE cdtExpression: Result := Result + ' ON UPDATE '+OnUpdateText; end; Result := Result + ' '; end; end; if InParts(cpVirtuality) and IsVirtual then begin Result := Result + 'AS ('+GenerationExpression+') ' + Virtuality + ' '; end; if InParts(cpComment) then begin if (Comment <> '') and FConnection.Parameters.IsAnyMySQL then Result := Result + 'COMMENT ' + FConnection.EscapeString(Comment) + ' '; end; if InParts(cpCollation) and (not IsVirtual) then begin if Collation <> '' then begin Result := Result + 'COLLATE '; if OverrideCollation <> '' then Result := Result + FConnection.EscapeString(OverrideCollation) + ' ' else Result := Result + FConnection.EscapeString(Collation) + ' '; end; end; Result := Trim(Result); end; function TTableColumn.ValueList: TStringList; begin // Same as TDBQuery.ValueList, but for callers which do not have a query result Result := TStringList.Create; Result.QuoteChar := ''''; Result.Delimiter := ','; if DataType.Index in [dbdtEnum, dbdtSet] then Result.DelimitedText := LengthSet; end; procedure TTableColumn.ParseDatatype(Source: String); var InLiteral: Boolean; ParenthLeft, i: Integer; begin DataType := Connection.GetDatatypeByName(Source, True); // Length / Set // Various datatypes, e.g. BLOBs, don't have any length property InLiteral := False; ParenthLeft := Pos('(', Source); if (ParenthLeft > 0) and DataType.HasLength then begin for i:=ParenthLeft+1 to Length(Source) do begin if (Source[i] = ')') and (not InLiteral) then break; if Source[i] = '''' then InLiteral := not InLiteral; end; LengthSet := Copy(Source, ParenthLeft+1, i-2); if LengthSet = DataType.DefaultSize.ToString then LengthSet := ''; end else begin LengthSet := ''; end; Unsigned := ExecRegExpr('\bunsigned\b', Source.ToLowerInvariant); ZeroFill := ExecRegExpr('\bzerofill\b', Source.ToLowerInvariant); end; function TTableColumn.CastAsText: String; begin // Cast data types which are incompatible to string functions to text columns Result := FConnection.QuoteIdent(Name); case FConnection.Parameters.NetTypeGroup of ngMySQL, ngSQLite: begin if DataType.Index in [dbdtUnknown, dbdtDate, dbdtDatetime, dbdtTime, dbdtTimestamp] then Result := 'CAST('+Result+' AS CHAR)'; end; ngMSSQL: begin // Be sure LEFT() and "col LIKE xyz" work with MSSQL // Also, prevent exceeding size limit of 8000 for NVARCHAR if DataType.Index in [dbdtUnknown, dbdtNtext, dbdtText] then Result := 'CAST('+Result+' AS NVARCHAR('+IntToStr(GRIDMAXDATA)+'))'; end; ngPgSQL: begin if (DataType.Index = dbdtUnknown) or (DataType.Category = dtcBinary) then Result := Result + '::text'; end; end; end; procedure TTableColumnList.Assign(Source: TTableColumnList); var Item, ItemCopy: TTableColumn; begin for Item in Source do begin ItemCopy := TTableColumn.Create(Item.Connection); ItemCopy.Assign(Item); Add(ItemCopy); end; end; { *** TTableKey } constructor TTableKey.Create(AOwner: TDBConnection); begin inherited Create; FConnection := AOwner; Columns := TStringList.Create; SubParts := TStringList.Create; Columns.OnChange := Modification; Subparts.OnChange := Modification; end; destructor TTableKey.Destroy; begin FreeAndNil(Columns); FreeAndNil(SubParts); inherited Destroy; end; procedure TTableKey.Assign(Source: TPersistent); var s: TTableKey; begin if Source is TTableKey then begin s := Source as TTableKey; Name := s.Name; OldName := s.OldName; IndexType := s.IndexType; OldIndexType := s.OldIndexType; Algorithm := s.Algorithm; Comment := s.Comment; Columns.Assign(s.Columns); SubParts.Assign(s.SubParts); Modified := s.Modified; Added := s.Added; end else inherited; end; procedure TTableKey.Modification(Sender: TObject); begin if not Added then Modified := True; end; function TTableKey.GetImageIndex: Integer; begin // Detect key icon index for specified index if IndexType = TTableKey.PRIMARY then Result := ICONINDEX_PRIMARYKEY else if IndexType = TTableKey.KEY then Result := ICONINDEX_INDEXKEY else if IndexType = TTableKey.UNIQUE then Result := ICONINDEX_UNIQUEKEY else if IndexType = TTableKey.FULLTEXT then Result := ICONINDEX_FULLTEXTKEY else if IndexType = TTableKey.SPATIAL then Result := ICONINDEX_SPATIALKEY else Result := -1; end; function TTableKey.SQLCode: String; var i: Integer; begin Result := ''; // Supress SQL error trying index creation with 0 column if Columns.Count = 0 then Exit; if IndexType = TTableKey.PRIMARY then Result := Result + 'PRIMARY KEY ' else begin if IndexType <> TTableKey.KEY then Result := Result + IndexType + ' '; Result := Result + 'INDEX ' + FConnection.QuoteIdent(Name) + ' '; end; Result := Result + '('; for i:=0 to Columns.Count-1 do begin Result := Result + FConnection.QuoteIdent(Columns[i]); if SubParts[i] <> '' then Result := Result + '(' + SubParts[i] + ')'; Result := Result + ', '; end; if Columns.Count > 0 then Delete(Result, Length(Result)-1, 2); Result := Result + ')'; if Algorithm <> '' then Result := Result + ' USING ' + Algorithm; if not Comment.IsEmpty then Result := Result + ' COMMENT ' + FConnection.EscapeString(Comment); end; procedure TTableKeyList.Assign(Source: TTableKeyList); var Item, ItemCopy: TTableKey; begin for Item in Source do begin ItemCopy := TTableKey.Create(Item.Connection); ItemCopy.Assign(Item); Add(ItemCopy); end; end; { *** TForeignKey } constructor TForeignKey.Create(AOwner: TDBConnection); begin inherited Create; FConnection := AOwner; Columns := TStringList.Create; Columns.StrictDelimiter := True; ForeignColumns := TStringList.Create; ForeignColumns.StrictDelimiter := True; // Explicit default action required, since MariaDB and MySQL have different defaults if it's left away, see issue #1320 OnUpdate := 'NO ACTION'; OnDelete := 'NO ACTION'; end; destructor TForeignKey.Destroy; begin FreeAndNil(Columns); FreeAndNil(ForeignColumns); inherited Destroy; end; procedure TForeignKey.Assign(Source: TPersistent); var s: TForeignKey; begin if Source is TForeignKey then begin s := Source as TForeignKey; KeyName := s.KeyName; OldKeyName := s.OldKeyName; Db := s.Db; ReferenceDb := s.ReferenceDb; ReferenceTable := s.ReferenceTable; OnUpdate := s.OnUpdate; OnDelete := s.OnDelete; Columns.Assign(s.Columns); ForeignColumns.Assign(s.ForeignColumns); Modified := s.Modified; Added := s.Added; KeyNameWasCustomized := s.KeyNameWasCustomized; end else inherited; end; function TForeignKey.SQLCode(IncludeSymbolName: Boolean): String; var i: Integer; TablePart: String; begin Result := ''; // Symbol names are unique in a db. In order to autocreate a valid name we leave the constraint clause away. if IncludeSymbolName then Result := 'CONSTRAINT '+FConnection.QuoteIdent(KeyName)+' '; Result := Result + 'FOREIGN KEY ('; for i:=0 to Columns.Count-1 do Result := Result + FConnection.QuoteIdent(Columns[i]) + ', '; if Columns.Count > 0 then Delete(Result, Length(Result)-1, 2); Result := Result + ') REFERENCES '; if (not ReferenceDb.IsEmpty) and (ReferenceTable.StartsWith(ReferenceDb)) then begin TablePart := ReferenceTable.Substring(Length(ReferenceDb) + 1); if ReferenceDb <> Db then Result := Result + FConnection.QuoteIdent(ReferenceDb) + '.' + FConnection.QuoteIdent(TablePart) else Result := Result + FConnection.QuoteIdent(TablePart); end else begin Result := Result + FConnection.QuoteIdent(ReferenceTable, True, '.'); end; Result := Result + ' ('; for i:=0 to ForeignColumns.Count-1 do Result := Result + FConnection.QuoteIdent(ForeignColumns[i]) + ', '; if ForeignColumns.Count > 0 then Delete(Result, Length(Result)-1, 2); Result := Result + ')'; if OnUpdate <> '' then Result := Result + ' ON UPDATE ' + OnUpdate; if OnDelete <> '' then Result := Result + ' ON DELETE ' + OnDelete; end; function TForeignKey.ReferenceTableObj: TDBObject; var RefDb, RefTable: String; begin // Find database object of reference table if (not ReferenceDb.IsEmpty) and (ReferenceTable.StartsWith(ReferenceDb)) then begin RefDb := ReferenceDb; RefTable := ReferenceTable.Substring(Length(ReferenceDb) + 1); end else begin RefDb := ReferenceTable.Substring(0, Pos('.', ReferenceTable)-1); if not RefDb.IsEmpty then begin RefTable := ReferenceTable.Substring(Length(RefDb)+1); end else begin RefDb := FConnection.Database; RefTable := ReferenceTable; end; end; Result := FConnection.FindObject(RefDb, RefTable); end; procedure TForeignKeyList.Assign(Source: TForeignKeyList); var Item, ItemCopy: TForeignKey; begin for Item in Source do begin ItemCopy := TForeignKey.Create(Item.Connection); ItemCopy.Assign(Item); Add(ItemCopy); end; end; { *** TCheckConstraint } constructor TCheckConstraint.Create(AOwner: TDBConnection); begin inherited Create; FConnection := AOwner; end; procedure TCheckConstraint.Assign(Source: TPersistent); var s: TCheckConstraint; begin if Source is TCheckConstraint then begin s := Source as TCheckConstraint; FName := s.Name; FCheckClause := s.CheckClause; FModified := s.Modified; FAdded := s.Added; end else inherited; end; function TCheckConstraint.SQLCode: String; begin Result := 'CONSTRAINT '+FConnection.QuoteIdent(FName)+' CHECK ('+FCheckClause+')'; end; procedure TCheckConstraintList.Assign(Source: TCheckConstraintList); var Item, ItemCopy: TCheckConstraint; begin for Item in Source do begin ItemCopy := TCheckConstraint.Create(Item.Connection); ItemCopy.Assign(Item); Add(ItemCopy); end; end; { TSQLFunctionList } constructor TSQLFunctionList.Create(AOwner: TDBConnection; SQLFunctionsFileOrder: String); var TryFiles: TStringList; TryFile: String; Ini: TMemIniFile; Sections: TStringList; IniFilePath, Section: String; SQLFunc: TSQLFunction; begin inherited Create(True); FOwner := AOwner; FCategories := TStringList.Create; FCategories.Duplicates := dupIgnore; FCategories.Sorted := True; // ensures dupIgnore works FNames := TStringList.Create; FNames.Duplicates := dupIgnore; FNames.Sorted := True; TryFiles := Explode(',', SQLFunctionsFileOrder); for TryFile in TryFiles do begin IniFilePath := ExtractFilePath(Application.ExeName) + 'functions-'+TryFile+'.ini'; if FileExists(IniFilePath) then begin FOwner.Log(lcInfo, 'Reading function definitions from '+IniFilePath); Ini := TMemIniFile.Create(IniFilePath); Sections := TStringList.Create; Ini.ReadSections(Sections); for Section in Sections do begin SQLFunc := TSQLFunction.Create; SQLFunc.Name := Ini.ReadString(Section, 'Name', Section); SQLFunc.Declaration := '(' + Ini.ReadString(Section, 'Declaration', '') + ')'; SQLFunc.Category := Ini.ReadString(Section, 'Category', ''); SQLFunc.Description := Ini.ReadString(Section, 'Description', ''); SQLFunc.Description := StringReplace(SQLFunc.Description, '\n', sLineBreak, [rfReplaceAll]); Add(SQLFunc); FCategories.Add(SQLFunc.Category); FNames.Add(SQLFunc.Name); end; Ini.Free; Break; end; end; end; procedure SQLite_CollationNeededCallback(userData: Pointer; ppDb:Psqlite3; eTextRep:integer; zName:PAnsiChar); cdecl; var Conn: TSQLiteConnection; begin // SQLite connection requests a yet non existing collation. Create it and show that in the log. // userData is a pointer to the connection object, see caller in SetActive() Conn := TSQLiteConnection(userData); Conn.Log(lcInfo, Format('Auto-creating collation "%s"', [zName])); Conn.Lib.sqlite3_create_collation(ppDb, zName, eTextRep, nil, SQLite_Collation); end; function SQLite_Collation(userData: Pointer; lenA: Integer; strA: PAnsiChar; lenB: Integer; strB: PAnsiChar): Integer; cdecl; begin // Implementation of a collation comparison, called by SQLite when an underlying table query needs it. // This is probably not always some case insensitive collation Result := AnsiCompareText(strA, strB); end; function mysql_authentication_dialog_ask; var Username, Password: String; Dialog: TfrmLogin; begin { From client_plugin.h: The C function with the name "mysql_authentication_dialog_ask", if exists, will be used by the "dialog" client authentication plugin when user input is needed. This function should be of mysql_authentication_dialog_ask_t type. If the function does not exists, a built-in implementation will be used. @param mysql mysql @param type type of the input 1 - normal string input 2 - password string @param prompt prompt @param buf a buffer to store the use input @param buf_len the length of the buffer @retval a pointer to the user input string. It may be equal to 'buf' or to 'mysql->password'. In all other cases it is assumed to be an allocated string, and the "dialog" plugin will free() it. Test suite: INSTALL PLUGIN three_attempts SONAME 'dialog.dll'; CREATE USER test_dialog IDENTIFIED VIA three_attempts USING 'SECRET'; } Username := ''; Password := ''; Dialog := TfrmLogin.Create(nil); Dialog.lblPrompt.Caption := String(prompt); Dialog.editUsername.Width := Dialog.editUsername.Width + (Dialog.editUsername.Left - Dialog.lblUsername.Left); Dialog.editPassword.Width := Dialog.editUsername.Width; Dialog.lblUsername.Visible := False; Dialog.lblPassword.Visible := False; Dialog.editUsername.Left := Dialog.lblUsername.Left; Dialog.editPassword.Left := Dialog.lblPassword.Left; Dialog.editUsername.Top := Dialog.lblPrompt.Top + Dialog.lblPrompt.Height + 15; Dialog.editPassword.Top := Dialog.editUsername.Top; Dialog.editUsername.Visible := _type=1; Dialog.editPassword.Visible := _type=2; Dialog.ShowModal; case _type of 1: Result := PAnsiChar(AnsiString(Dialog.editUsername.Text)); 2: Result := PAnsiChar(AnsiString(Dialog.editPassword.Text)); else raise EDbError.CreateFmt(_('Unsupported type (%d) in %s.'), [_type, 'mysql_authentication_dialog_ask']); end; Dialog.Free; end; end.