{ This file is part of the Free Pascal run time library. Copyright (c) 1999-2022 by Michael van Canney and other members of the Free Pascal development team Mysql database connection component, shared parts See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} {$IFDEF MYSQL80_UP} {$DEFINE MYSQL57_UP} {$ENDIF} {$IFDEF MYSQL57_UP} {$DEFINE MYSQL56_UP} {$ENDIF} {$IFDEF MYSQL56_UP} {$DEFINE MYSQL55_UP} {$ENDIF} {$IFDEF MYSQL55_UP} {$DEFINE MYSQL51_UP} {$ENDIF} {$IFDEF MYSQL51_UP} {$DEFINE MYSQL50_UP} {$ENDIF} {$mode objfpc}{$H+} interface uses Classes, SysUtils,bufdataset,sqldb,db,ctypes,fmtbcd, {$IFDEF mysql80} mysql80dyn; {$ELSE} {$IFDEF mysql57} mysql57dyn; {$ELSE} {$IFDEF mysql56} mysql56dyn; {$ELSE} {$IFDEF mysql55} mysql55dyn; {$ELSE} {$IFDEF mysql51} mysql51dyn; {$ELSE} {$IfDef mysql50} mysql50dyn; {$ELSE} {$IfDef mysql41} mysql41dyn; {$ELSE} mysql40dyn; {$EndIf} {$EndIf} {$endif} {$endif} {$ENDIF} {$ENDIF} {$ENDIF} Const MySQLVersion = {$IFDEF mysql80} '8.0'; {$ELSE} {$IFDEF mysql57} '5.7'; {$ELSE} {$IFDEF mysql56} '5.6'; {$ELSE} {$IFDEF mysql55} '5.5'; {$ELSE} {$IFDEF mysql51} '5.1'; {$else} {$IfDef mysql50} '5.0'; {$ELSE} {$IfDef mysql41} '4.1'; {$ELSE} '4.0'; {$EndIf} {$EndIf} {$endif} {$endif} {$ENDIF} {$ENDIF} {$ENDIF} MariaDBVersion = {$IFDEF mysql57} '10.'; {$ELSE} {$IFDEF mysql56} // MariaDB 10.0 is compatible with MySQL 5.6 '10.'; {$ELSE} // MariaDB 5.1..5.5 presumably report the same version number as MySQL MySQLVersion; {$ENDIF} {$ENDIF} Type TTransactionName = Class(TSQLHandle) protected end; { TCursorName } TCursorName = Class(TSQLCursor) protected FRes: PMYSQL_RES; { Record pointer } // Statement with param placeholders $1 $2 etc. FPreparedStatement : String; // Statement with param placeholders replaced with actual values. FActualStatement : String; FStatement : String; Row : MYSQL_ROW; Lengths : pculong; { Lengths of the columns of the current row } RowsAffected : QWord; LastInsertID : QWord; ParamBinding : TParamBinding; ParamReplaceString : String; MapDSRowToMSQLRow : array of integer; end; { TConnectionName } TConnectionName = class (TSQLConnection) private FSkipLibraryVersionCheck : Boolean; FHostInfo: String; FServerInfo: String; FMySQL : PMySQL; {$IFDEF MYSQL50_UP} FConnectionCharsetInfo: MY_CHARSET_INFO; {$ENDIF} function GetClientInfo: string; function GetServerStatus: String; procedure ConnectMySQL(var HMySQL: PMySQL); procedure ExecuteDirectMySQL(const query : string); function InternalStrToBCD(C: pchar; Len: integer): tBCD; function InternalStrToCurrency(C: pchar; Len: integer): Currency; function InternalStrToDate(C: pchar; Len: integer): TDateTime; function InternalStrToDateTime(C: pchar; Len: integer): TDateTime; function InternalStrToFloat(C: pchar; Len: integer): Extended; function InternalStrToInt(C: pchar; Len: integer): integer; function InternalStrToDWord(C: pchar; Len: integer): DWord; function InternalStrToInt64(C: pchar; Len: integer): Int64; function InternalStrToTime(C: pchar; Len: integer): TDateTime; function StrToMSecs(C: pchar; Len: integer): Word; {$IFDEF MYSQL40} function InternalStrToTimeStamp(C: pchar; Len: integer): TDateTime; {$ENDIF} protected Procedure ConnectToServer; virtual; Procedure SelectDatabase; virtual; function MySQLDataType(AField: PMYSQL_FIELD; var NewType: TFieldType; var NewSize: Integer): Boolean; function MySQLWriteData(AField: PMYSQL_FIELD; FieldDef: TFieldDef; Source, Dest: PChar; Len: integer; out CreateBlob : boolean): Boolean; function EscapeString(const Str : string) : string; // SQLConnection methods procedure DoInternalConnect; override; procedure DoInternalDisconnect; override; function GetHandle : pointer; override; function GetConnectionCharSet: string; override; function GetAsSQLText(Param : TParam) : string; overload; override; Function AllocateCursorHandle : TSQLCursor; override; Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override; Function AllocateTransactionHandle : TSQLHandle; override; function StrToStatementType(s : string) : TStatementType; override; procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); override; procedure UnPrepareStatement(cursor:TSQLCursor); override; procedure FreeFldBuffers(cursor : TSQLCursor); override; procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction;AParams : TParams); override; procedure AddFieldDefs(cursor: TSQLCursor; FieldDefs : TfieldDefs); override; function Fetch(cursor : TSQLCursor) : boolean; override; function LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; override; procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor;ATransaction : TSQLTransaction); override; function GetTransactionHandle(trans : TSQLHandle): pointer; override; function Commit(trans : TSQLHandle) : boolean; override; function RollBack(trans : TSQLHandle) : boolean; override; function StartdbTransaction(trans : TSQLHandle; AParams : string) : boolean; override; procedure CommitRetaining(trans : TSQLHandle); override; procedure RollBackRetaining(trans : TSQLHandle); override; function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override; procedure UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); override; function RowsAffected(cursor: TSQLCursor): TRowsCount; override; function RefreshLastInsertID(Query : TCustomSQLQuery; Field : TField): Boolean; override; Public constructor Create(AOwner : TComponent); override; {$IFNDEF MYSQL50_UP} procedure GetFieldNames(const TableName : string; List : TStrings); override; procedure GetTableNames(List : TStrings; SystemTables : Boolean = false); override; {$ENDIF} function GetConnectionInfo(InfoType:TConnInfoType): string; override; Function GetInsertID: int64; procedure CreateDB; override; procedure DropDB; override; Property ServerInfo : String Read FServerInfo; Property HostInfo : String Read FHostInfo; property ClientInfo: string read GetClientInfo; property ServerStatus : String read GetServerStatus; published Property SkipLibraryVersionCheck : Boolean Read FSkipLibraryVersionCheck Write FSkipLibraryVersionCheck; property DatabaseName; property HostName; property KeepConnection; property LoginPrompt; property Params; property Port stored false; property OnLogin; end; { TMySQLConnectionDef } TMySQLConnectionDef = Class(TConnectionDef) Class Function TypeName : String; override; Class Function ConnectionClass : TSQLConnectionClass; override; Class Function Description : String; override; Class Function DefaultLibraryName : String; override; Class Function LoadFunction : TLibraryLoadFunction; override; Class Function UnLoadFunction : TLibraryUnLoadFunction; override; Class Function LoadedLibraryName : string; override; end; {$IFDEF mysql80} TMySQL80Connection = Class(TConnectionName); TMySQL80ConnectionDef = Class(TMySQLConnectionDef); TMySQL80Transaction = Class(TTransactionName); TMySQL80Cursor = Class(TCursorName); {$ELSE} {$IFDEF mysql57} TMySQL57Connection = Class(TConnectionName); TMySQL57ConnectionDef = Class(TMySQLConnectionDef); TMySQL57Transaction = Class(TTransactionName); TMySQL57Cursor = Class(TCursorName); {$ELSE} {$IFDEF mysql56} TMySQL56Connection = Class(TConnectionName); TMySQL56ConnectionDef = Class(TMySQLConnectionDef); TMySQL56Transaction = Class(TTransactionName); TMySQL56Cursor = Class(TCursorName); {$ELSE} {$ifdef mysql55} TMySQL55Connection = Class(TConnectionName); TMySQL55ConnectionDef = Class(TMySQLConnectionDef); TMySQL55Transaction = Class(TTransactionName); TMySQL55Cursor = Class(TCursorName); {$else} {$IfDef mysql51} TMySQL51Connection = Class(TConnectionName); TMySQL51ConnectionDef = Class(TMySQLConnectionDef); TMySQL51Transaction = Class(TTransactionName); TMySQL51Cursor = Class(TCursorName); {$ELSE} {$IfDef mysql50} TMySQL50Connection = Class(TConnectionName); TMySQL50ConnectionDef = Class(TMySQLConnectionDef); TMySQL50Transaction = Class(TTransactionName); TMySQL50Cursor = Class(TCursorName); {$ELSE} {$IfDef mysql41} TMySQL41Connection = Class(TConnectionName); TMySQL41ConnectionDef = Class(TMySQLConnectionDef); TMySQL41Transaction = Class(TTransactionName); TMySQL41Cursor = Class(TCursorName); {$ELSE} TMySQL40Connection = Class(TConnectionName); TMySQL40ConnectionDef = Class(TMySQLConnectionDef); TMySQL40Transaction = Class(TTransactionName); TMySQL40Cursor = Class(TCursorName); {$EndIf} {$endif} {$EndIf} {$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF} implementation uses dbconst, StrUtils, DateUtils; const Mysql_Option_Names : array[mysql_option] of string = ( 'MYSQL_OPT_CONNECT_TIMEOUT', 'MYSQL_OPT_COMPRESS', 'MYSQL_OPT_NAMED_PIPE', 'MYSQL_INIT_COMMAND', 'MYSQL_READ_DEFAULT_FILE', 'MYSQL_READ_DEFAULT_GROUP', 'MYSQL_SET_CHARSET_DIR', 'MYSQL_SET_CHARSET_NAME', 'MYSQL_OPT_LOCAL_INFILE', 'MYSQL_OPT_PROTOCOL', 'MYSQL_SHARED_MEMORY_BASE_NAME', 'MYSQL_OPT_READ_TIMEOUT', 'MYSQL_OPT_WRITE_TIMEOUT', 'MYSQL_OPT_USE_RESULT' {$IFDEF MYSQL80} ,'MYSQL_REPORT_DATA_TRUNCATION', 'MYSQL_OPT_RECONNECT', 'MYSQL_PLUGIN_DIR', 'MYSQL_DEFAULT_AUTH', 'MYSQL_OPT_BIND', 'MYSQL_OPT_SSL_KEY', 'MYSQL_OPT_SSL_CERT', 'MYSQL_OPT_SSL_CA', 'MYSQL_OPT_SSL_CAPATH', 'MYSQL_OPT_SSL_CIPHER', 'MYSQL_OPT_SSL_CRL', 'MYSQL_OPT_SSL_CRLPATH', 'MYSQL_OPT_CONNECT_ATTR_RESET', 'MYSQL_OPT_CONNECT_ATTR_ADD', 'MYSQL_OPT_CONNECT_ATTR_DELETE', 'MYSQL_SERVER_PUBLIC_KEY', 'MYSQL_ENABLE_CLEARTEXT_PLUGIN', 'MYSQL_OPT_CAN_HANDLE_EXPIRED_PASSWORDS', 'MYSQL_OPT_MAX_ALLOWED_PACKET', 'MYSQL_OPT_NET_BUFFER_LENGTH', 'MYSQL_OPT_TLS_VERSION', 'MYSQL_OPT_SSL_MODE', 'MYSQL_OPT_GET_SERVER_PUBLIC_KEY', 'MYSQL_OPT_RETRY_COUNT', 'MYSQL_OPT_OPTIONAL_RESULTSET_METADATA', 'MYSQL_OPT_SSL_FIPS_MODE', 'MYSQL_OPT_TLS_CIPHERSUITES', 'MYSQL_OPT_COMPRESSION_ALGORITHMS', 'MYSQL_OPT_ZSTD_COMPRESSION_LEVEL', 'MYSQL_OPT_LOAD_DATA_LOCAL_DIR' {$ELSE} ,'MYSQL_OPT_USE_REMOTE_CONNECTION', 'MYSQL_OPT_USE_EMBEDDED_CONNECTION', 'MYSQL_OPT_GUESS_CONNECTION', 'MYSQL_SET_CLIENT_IP', 'MYSQL_SECURE_AUTH' {$IFDEF MYSQL50_UP} ,'MYSQL_REPORT_DATA_TRUNCATION', 'MYSQL_OPT_RECONNECT' {$IFDEF mysql51_UP} ,'MYSQL_OPT_SSL_VERIFY_SERVER_CERT' {$IFDEF mysql55_UP} ,'MYSQL_PLUGIN_DIR', 'MYSQL_DEFAULT_AUTH' {$IFDEF MYSQL56_UP} ,'MYSQL_OPT_BIND' ,'MYSQL_OPT_SSL_KEY', 'MYSQL_OPT_SSL_CERT', 'MYSQL_OPT_SSL_CA', 'MYSQL_OPT_SSL_CAPATH', 'MYSQL_OPT_SSL_CIPHER', 'MYSQL_OPT_SSL_CRL', 'MYSQL_OPT_SSL_CRLPATH' ,'MYSQL_OPT_CONNECT_ATTR_RESET', 'MYSQL_OPT_CONNECT_ATTR_ADD', 'MYSQL_OPT_CONNECT_ATTR_DELETE' ,'MYSQL_SERVER_PUBLIC_KEY' ,'MYSQL_ENABLE_CLEARTEXT_PLUGIN' ,'MYSQL_OPT_CAN_HANDLE_EXPIRED_PASSWORDS' {$IFDEF MYSQL57_UP} ,'MYSQL_OPT_SSL_ENFORCE' {$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF} ); Resourcestring SErrServerConnectFailed = 'Server connect failed.'; SErrSetCharsetFailed = 'Failed to set connection character set: %s'; SErrDatabaseSelectFailed = 'Failed to select database: %s'; //SErrDatabaseCreate = 'Failed to create database: %s'; //SErrDatabaseDrop = 'Failed to drop database: %s'; //SErrNoData = 'No data for record'; SErrExecuting = 'Error executing query: %s'; SErrFetchingdata = 'Error fetching row data: %s'; SErrGettingResult = 'Error getting result set: %s'; SErrNoQueryResult = 'No result from query.'; SErrVersionMismatch = '%s can not work with the installed MySQL client version: Expected (%s), got (%s).'; SErrSettingParameter = 'Error setting parameter "%s"'; Procedure MySQLError(R : PMySQL; Msg: String; Comp : TComponent); Var MySQLError, MySQLState : String; MySQLErrno: integer; begin If (R<>Nil) then begin MySQLError:=StrPas(mysql_error(R)); MySQLErrno:=mysql_errno(R); MySQLState:=StrPas(mysql_sqlstate(R)); end else begin MySQLError:=''; MySQLErrno:=0; MySQLState:=''; end; raise ESQLDatabaseError.CreateFmt(Msg, [MySQLError], Comp, MySQLErrno, MySQLState); end; function MysqlOption(const OptionName: string; out AMysql_Option: mysql_option) : boolean; var AMysql_Option_i: mysql_option; begin result := false; for AMysql_Option_i:=low(AMysql_Option) to high(AMysql_Option) do if sametext(Mysql_Option_Names[AMysql_Option_i],OptionName) then begin result := true; AMysql_Option:=AMysql_Option_i; break; end; end; { TConnectionName } function TConnectionName.StrToStatementType(s : string) : TStatementType; begin s:=Lowercase(s); if (s='analyze') or (s='check') or (s='checksum') or (s='optimize') or (s='repair') or (s='show') then exit(stSelect) else if s='call' then exit(stExecProcedure) else Result := inherited StrToStatementType(s); end; function TConnectionName.GetClientInfo: string; begin // To make it possible to call this if there's no connection yet InitialiseMysql; Try Result:=strpas(mysql_get_client_info()); Finally ReleaseMysql; end; end; function TConnectionName.GetServerStatus: String; begin CheckConnected; Result := mysql_stat(FMYSQL); end; Function TConnectionName.GetInsertID: int64; begin CheckConnected; Result:=mysql_insert_id(GetHandle); end; procedure TConnectionName.ConnectMySQL(var HMySQL: PMySQL); Var APort : Cardinal; i,e: integer; AMysql_Option: mysql_option; OptStr: string; OptInt: cuint; Opt: pointer; begin HMySQL := mysql_init(HMySQL); APort:=Abs(StrToIntDef(Params.Values['Port'],0)); for i := 0 to Params.Count-1 do begin if MysqlOption(Params.Names[i],AMysql_Option) then begin OptStr:=Params.ValueFromIndex[i]; val(OptStr,OptInt,e); if e=0 then Opt := @OptInt else Opt := pchar(OptStr); if mysql_options(HMySQL,AMysql_Option,Opt) <> 0 then MySQLError(HMySQL,Format(SErrSettingParameter,[Params.Names[i]]),Self); end; end; if mysql_real_connect(HMySQL,PChar(HostName),PChar(UserName),PChar(Password),Nil,APort,Nil,CLIENT_MULTI_RESULTS) = nil then //CLIENT_MULTI_RESULTS is required by CALL SQL statement(executes stored procedure), that produces result sets MySQLError(HMySQL,SErrServerConnectFailed,Self); if (trim(CharSet) <> '') then // major_version*10000 + minor_version *100 + sub_version if (50007 <= mysql_get_server_version(HMySQL)) then begin // Only available for MySQL 5.0.7 and later... if mysql_set_character_set(HMySQL, PChar(CharSet)) <> 0 then MySQLError(HMySQL,SErrSetCharsetFailed,Self); end else if mysql_query(HMySQL,PChar('SET NAMES ''' + EscapeString(CharSet) +'''')) <> 0 then MySQLError(HMySQL,SErrExecuting,Self); end; function TConnectionName.GetAsSQLText(Param: TParam) : string; begin if (not assigned(Param)) or Param.IsNull then Result := 'Null' else if Param.DataType in [ftString,ftFixedChar,ftMemo] then Result := '''' + EscapeString(GetAsString(Param)) + '''' else if Param.DataType in [ftBlob,ftBytes,ftVarBytes] then Result := '''' + EscapeString(Param.AsString) + '''' else Result := inherited GetAsSQLText(Param); end; Procedure TConnectionName.ConnectToServer; begin ConnectMySQL(FMySQL); FServerInfo := strpas(mysql_get_server_info(FMYSQL)); FHostInfo := strpas(mysql_get_host_info(FMYSQL)); {$IFDEF MYSQL50_UP} mysql_get_character_set_info(FMYSQL, @FConnectionCharsetInfo); {$ENDIF} end; Procedure TConnectionName.SelectDatabase; begin if mysql_select_db(FMySQL,pchar(DatabaseName))<>0 then MySQLError(FMySQL,SErrDatabaseSelectFailed,Self); end; procedure TConnectionName.CreateDB; begin ExecuteDirectMySQL('CREATE DATABASE ' +DatabaseName); end; procedure TConnectionName.DropDB; begin ExecuteDirectMySQL('DROP DATABASE ' +DatabaseName); end; procedure TConnectionName.ExecuteDirectMySQL(const query : string); var AMySQL : PMySQL; begin CheckDisConnected; InitialiseMysql; try AMySQL := nil; ConnectMySQL(AMySQL); try if mysql_query(AMySQL,pchar(query))<>0 then MySQLError(AMySQL,SErrExecuting,Self); finally mysql_close(AMySQL); end; finally ReleaseMysql; end; end; function TConnectionName.EscapeString(const Str: string): string; var Len : integer; begin SetLength(result,length(str)*2+1); Len := mysql_real_escape_string(FMySQL,pchar(Result),pchar(Str),length(Str)); SetLength(result,Len); end; procedure TConnectionName.DoInternalConnect; var FullVersion: string; begin InitialiseMysql; if not SkipLibraryVersionCheck then begin FullVersion:=strpas(mysql_get_client_info()); // Version string should start with version number: // Note: in case of MariaDB version mismatch: tough luck, we report MySQL // version only. if (pos(MySQLVersion, FullVersion) <> 1) and (pos(MariaDBVersion, FullVersion) <> 1) then Raise EInOutError.CreateFmt(SErrVersionMisMatch,[ClassName,MySQLVersion,FullVersion]); end; inherited DoInternalConnect; ConnectToServer; SelectDatabase; end; procedure TConnectionName.DoInternalDisconnect; begin inherited DoInternalDisconnect; mysql_close(FMySQL); FMySQL:=Nil; ReleaseMysql; end; function TConnectionName.GetHandle: pointer; begin Result:=FMySQL; end; function TConnectionName.GetConnectionCharSet: string; begin Result:=StrPas(mysql_character_set_name(FMySQL)); end; Function TConnectionName.AllocateCursorHandle: TSQLCursor; begin {$IFDEF mysql80} Result:=TMySQL80Cursor.Create; {$ELSE} {$IFDEF mysql57} Result:=TMySQL57Cursor.Create; {$ELSE} {$IFDEF mysql56} Result:=TMySQL56Cursor.Create; {$ELSE} {$IfDef mysql55} Result:=TMySQL55Cursor.Create; {$ELSE} {$IfDef mysql51} Result:=TMySQL51Cursor.Create; {$ELSE} {$IfDef mysql50} Result:=TMySQL50Cursor.Create; {$ELSE} {$IfDef mysql41} Result:=TMySQL41Cursor.Create; {$ELSE} Result:=TMySQL40Cursor.Create; {$EndIf} {$EndIf} {$EndIf} {$EndIf} {$ENDIF} {$ENDIF} {$ENDIF} end; Procedure TConnectionName.DeAllocateCursorHandle(var cursor : TSQLCursor); begin FreeAndNil(cursor); end; Function TConnectionName.AllocateTransactionHandle: TSQLHandle; begin // Result:=TTransactionName.Create; Result := nil; end; procedure TConnectionName.PrepareStatement(cursor: TSQLCursor; ATransaction: TSQLTransaction; buf: string;AParams : TParams); begin // if assigned(AParams) and (AParams.count > 0) then // DatabaseError('Parameters (not) yet supported for the MySQL SqlDB connection.',self); With Cursor as TCursorName do begin FPreparedStatement:=Buf; if assigned(AParams) and (AParams.count > 0) then FPreparedStatement := AParams.ParseSQL(FPreparedStatement,false,sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions,psSimulated,paramBinding,ParamReplaceString); FPrepared:=True; end; end; procedure TConnectionName.UnPrepareStatement(cursor: TSQLCursor); Var C : TCursorName; begin C:=Cursor as TCursorName; if assigned(C.FRes) then //ExecSQL with dataset returned begin mysql_free_result(C.FRes); C.FRes:=nil; end; end; procedure TConnectionName.FreeFldBuffers(cursor: TSQLCursor); Var C : TCursorName; begin C:=Cursor as TCursorName; if assigned(C.FRes) then begin mysql_free_result(C.FRes); C.FRes:=Nil; end; C.FInitFieldDef:=True; SetLength(c.MapDSRowToMSQLRow,0); inherited; end; procedure TConnectionName.Execute(cursor: TSQLCursor; atransaction: tSQLtransaction;AParams : TParams); Var C : TCursorName; i : integer; ParamNames,ParamValues : array of string; Res: PMYSQL_RES; Status : Integer; begin C:=Cursor as TCursorName; If (C.FRes=Nil) then begin if Assigned(AParams) and (AParams.count > 0) then begin setlength(ParamNames,AParams.Count); setlength(ParamValues,AParams.Count); for i := 0 to AParams.count -1 do begin ParamNames[AParams.count-i-1] := C.ParamReplaceString+inttostr(AParams[i].Index+1); ParamValues[AParams.count-i-1] := GetAsSQLText(AParams[i]); end; C.FActualStatement := stringsreplace(C.FPreparedStatement,ParamNames,ParamValues,[rfReplaceAll]); end else C.FActualStatement:=C.FPreparedStatement; if LogEvent(detParamValue) then LogParams(AParams); if LogEvent(detExecute) then Log(detExecute, C.FPreparedStatement); if LogEvent(detActualSQL) then Log(detActualSQL,C.FActualStatement); if mysql_query(FMySQL,Pchar(C.FActualStatement))<>0 then begin if not ForcedClose then MySQLError(FMYSQL,SErrExecuting,Self) else //don't return a resulset. We are shutting down, not opening. begin C.RowsAffected:=0; C.FSelectable:= False; C.FRes:=nil; end; end else begin C.RowsAffected := mysql_affected_rows(FMYSQL); C.LastInsertID := mysql_insert_id(FMYSQL); C.FSelectable := False; repeat Res:=mysql_store_result(FMySQL); //returns a null pointer also if the statement didn't return a result set if mysql_errno(FMySQL)<>0 then begin if not ForcedClose then MySQLError(FMySQL, SErrGettingResult, Self) else begin C.RowsAffected:=0; C.FSelectable:= False; C.FRes:=nil; break; end; end; if Res<>nil then begin mysql_free_result(C.FRes); C.FRes:=Res; C.FSelectable:=True; end; Status:=mysql_next_result(FMySQL); if (Status>0) then begin if not ForcedClose then MySQLError(FMySQL, SErrGettingResult, Self) else begin C.RowsAffected:=0; C.FSelectable:= False; C.FRes:=nil; break; end; end; until (Status<>0); end; end; end; function TConnectionName.MySQLDataType(AField: PMYSQL_FIELD; var NewType: TFieldType; var NewSize: Integer): Boolean; var ASize: culong; ADecimals: cuint; begin Result := True; ASize := AField^.length; NewSize := 0; case AField^.ftype of FIELD_TYPE_LONGLONG: begin NewType := ftLargeint; end; FIELD_TYPE_TINY, FIELD_TYPE_SHORT, FIELD_TYPE_YEAR: begin if AField^.flags and UNSIGNED_FLAG <> 0 then NewType := ftWord else NewType := ftSmallint; end; FIELD_TYPE_LONG, FIELD_TYPE_INT24: begin if AField^.flags and AUTO_INCREMENT_FLAG <> 0 then NewType := ftAutoInc else NewType := ftInteger; end; {$ifdef mysql50_up} FIELD_TYPE_NEWDECIMAL, {$endif} FIELD_TYPE_DECIMAL: begin ADecimals:=AField^.decimals; if (ADecimals < 5) and (ASize-2-ADecimals < 15) then //ASize is display size i.e. with sign and decimal point NewType := ftBCD else if (ADecimals = 0) and (ASize < 20) then NewType := ftLargeInt else NewType := ftFmtBCD; NewSize := ADecimals; end; FIELD_TYPE_FLOAT, FIELD_TYPE_DOUBLE: begin NewType := ftFloat; end; FIELD_TYPE_TIMESTAMP, FIELD_TYPE_DATETIME: begin NewType := ftDateTime; end; FIELD_TYPE_DATE: begin NewType := ftDate; end; FIELD_TYPE_TIME: begin NewType := ftTime; end; FIELD_TYPE_VAR_STRING, FIELD_TYPE_STRING, FIELD_TYPE_ENUM, FIELD_TYPE_SET: begin // Since mysql server version 5.0.3 string-fields with a length of more // then 256 characters are suported if AField^.ftype = FIELD_TYPE_STRING then NewType := ftFixedChar else NewType := ftString; {$IFDEF MYSQL50_UP} if AField^.charsetnr = 63 then begin //BINARY vs. CHAR, VARBINARY vs. VARCHAR if NewType = ftFixedChar then NewType := ftBytes else NewType := ftVarBytes; NewSize := ASize; end else NewSize := ASize div FConnectionCharsetInfo.mbmaxlen; {$ELSE} NewSize := ASize; {$ENDIF} end; FIELD_TYPE_TINY_BLOB..FIELD_TYPE_BLOB: begin {$IFDEF MYSQL50_UP} if AField^.charsetnr = 63 then //character set is binary NewType := ftBlob else NewType := ftMemo; {$ELSE} NewType := ftBlob; {$ENDIF} end; {$IFDEF MYSQL50_UP} FIELD_TYPE_BIT: NewType := ftLargeInt; {$ENDIF} else Result := False; end; end; procedure TConnectionName.AddFieldDefs(cursor: TSQLCursor; FieldDefs: TfieldDefs); var C : TCursorName; I, FC: Integer; field: PMYSQL_FIELD; DFT: TFieldType; DFS: Integer; begin // Writeln('MySQL: Adding fielddefs'); C:=(Cursor as TCursorName); If (C.FRes=Nil) then begin // Writeln('res is nil'); MySQLError(FMySQL,SErrNoQueryResult,Self); end; // Writeln('MySQL: have result'); FC:=mysql_num_fields(C.FRes); SetLength(c.MapDSRowToMSQLRow,FC); For I := 0 to FC-1 do begin field := mysql_fetch_field_direct(C.FRES, I); // Writeln('MySQL: creating fielddef ',I+1); if MySQLDataType(field, DFT, DFS) then begin AddFieldDef(FieldDefs, I+1, field^.name, DFT, DFS, -1, False, (field^.flags and (AUTO_INCREMENT_FLAG or NOT_NULL_FLAG {$IFDEF MYSQL50_UP}or NO_DEFAULT_VALUE_FLAG{$ENDIF})) = (NOT_NULL_FLAG {$IFDEF MYSQL50_UP}or NO_DEFAULT_VALUE_FLAG{$ENDIF}), False); c.MapDSRowToMSQLRow[I] := I; end end; // Writeln('MySQL: Finished adding fielddefs'); end; function TConnectionName.Fetch(cursor: TSQLCursor): boolean; Var C : TCursorName; begin C:=Cursor as TCursorName; C.Row:=MySQL_Fetch_row(C.FRes); Result:=(C.Row<>Nil); if Result then C.Lengths := mysql_fetch_lengths(C.FRes) else C.Lengths := nil; end; function TConnectionName.LoadField(cursor : TSQLCursor; FieldDef : TfieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; var field: PMYSQL_FIELD; C : TCursorName; i : integer; begin // Writeln('LoadFieldsFromBuffer'); C:=Cursor as TCursorName; if (C.Row=nil) or (C.Lengths=nil) then begin // Writeln('LoadFieldsFromBuffer: row=nil'); MySQLError(FMySQL,SErrFetchingData,Self); end; i := c.MapDSRowToMSQLRow[FieldDef.FieldNo-1]; field := mysql_fetch_field_direct(C.FRES, i); Result := MySQLWriteData(field, FieldDef, C.Row[i], Buffer, C.Lengths[i], CreateBlob); end; procedure TConnectionName.LoadBlobIntoBuffer(FieldDef: TFieldDef; ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction); var C : TCursorName; i : integer; len : longint; begin C:=Cursor as TCursorName; if (C.Row=nil) or (C.Lengths=nil) then MySQLError(FMySQL,SErrFetchingData,Self); i := c.MapDSRowToMSQLRow[FieldDef.FieldNo-1]; len := C.Lengths[i]; ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, len); Move(C.Row[i]^, ABlobBuf^.BlobBuffer^.Buffer^, len); ABlobBuf^.BlobBuffer^.Size := len; end; function TConnectionName.InternalStrToInt(C: pchar; Len: integer): integer; Var S : String; begin Result := 0; if (Len=0) or (C=Nil) then exit; SetString(S,C,Len); Result:=StrToInt(S); end; function TConnectionName.InternalStrToDWord(C: pchar; Len: integer): DWord; Var S : String; begin Result := 0; if (Len=0) or (C=Nil) then exit; SetString(S,C,Len); Result:=StrToDWord(S); end; function TConnectionName.InternalStrToInt64(C: pchar; Len: integer): Int64; Var S : String; begin Result := 0; if (Len=0) or (C=Nil) then exit; SetString(S,C,Len); Result:=StrToInt64(S); end; function TConnectionName.InternalStrToFloat(C: pchar; Len: integer): Extended; var Tmp: string; begin SetString(Tmp, C, Len); if Tmp='' then Exit(0); Result := StrToFloat(Tmp, FSQLFormatSettings); end; function TConnectionName.InternalStrToCurrency(C: pchar; Len: integer): Currency; var Tmp: string; begin SetString(Tmp, C, Len); if Tmp='' then Exit(0); Result := StrToCurr(Tmp, FSQLFormatSettings); end; function TConnectionName.InternalStrToBCD(C: pchar; Len: integer): tBCD; var Tmp: string; begin SetString(Tmp, C, Len); if Tmp='' then Exit(0); Result := StrToBCD(Tmp, FSQLFormatSettings); end; function TConnectionName.InternalStrToDate(C: pchar; Len: integer): TDateTime; var EY, EM, ED: Word; begin if Len=0 then Exit(0); if Len<10 then raise EConvertError.Create('Invalid date string'); EY := InternalStrToInt(C,4); EM := InternalStrToInt(C+5,2); ED := InternalStrToInt(C+8,2); if (EY = 0) or (EM = 0) or (ED = 0) then Result:=0 else Result:=EncodeDate(EY, EM, ED); end; function TConnectionName.StrToMSecs(C: pchar; Len: integer): Word; {$IFDEF MYSQL56_UP} var I: Integer; d, MSecs: double; {$ENDIF} begin {$IFDEF MYSQL56_UP} // datetime(n), where n is fractional seconds precision (between 0 and 6) MSecs := 0; d := 100; for I := 1 to Len do begin case C^ of '0'..'9': MSecs := MSecs + (ord(C^)-ord('0'))*d; #0: break; end; d := d / 10; Inc(C); end; Result := Round(MSecs); {$ELSE} Result := 0; {$ENDIF} end; function TConnectionName.InternalStrToDateTime(C: pchar; Len: integer): TDateTime; var EY, EM, ED: Word; EH, EN, ES, EMS: Word; begin if Len=0 then Exit(0); if Len<19 then raise EConvertError.Create('Invalid datetime string'); EY := InternalStrToInt(C,4); EM := InternalStrToInt(C+5,2); ED := InternalStrToInt(C+8,2); EH := InternalStrToInt(C+11, 2); EN := InternalStrToInt(C+14, 2); ES := InternalStrToInt(C+17, 2); if Len>20 then EMS := StrToMSecs(C+20, Len-20) else EMS := 0; if (EY = 0) or (EM = 0) or (ED = 0) then Result := 0 else Result := EncodeDate(EY, EM, ED); Result := ComposeDateTime(Result, EncodeTimeInterval(EH, EN, ES, EMS)); end; function TConnectionName.InternalStrToTime(C: pchar; Len: integer): TDateTime; var EH, EM, ES, EMS: Word; M: PChar; I: Integer; begin if Len=0 then Exit(0); if Len<8 then raise EConvertError.Create('Invalid time string'); //hours can be 2 or 3 digits M:=C; for I := 1 to Len do begin if M^=':' then break; Inc(M); end; if M^<>':' then raise EConvertError.Create('Invalid time string'); EH := InternalStrToInt(C, NativeInt(M-C)); EM := InternalStrToInt(M+1, 2); ES := InternalStrToInt(M+4, 2); if Len>NativeInt(M-C)+7 then EMS := StrToMSecs(M+7, Len-(NativeInt(M-C)+7)) else EMS := 0; Result := EncodeTimeInterval(EH, EM, ES, EMS); end; {$IFDEF mysql40} function TConnectionName.InternalStrToTimeStamp(C: pchar; Len: integer): TDateTime; var EY, EM, ED: Word; EH, EN, ES: Word; begin if Len=0 then Exit(0); if Len<14 then raise EConvertError.Create('Invalid timestamp string'); EY := InternalStrToInt(C, 4); EM := InternalStrToInt(C+4, 2)); ED := InternalStrToInt(C+6, 2)); EH := InternalStrToInt(C+8, 2)); EN := InternalStrToInt(C+10, 2)); ES := InternalStrToInt(C+12, 2)); if (EY = 0) or (EM = 0) or (ED = 0) then Result := 0 else Result := EncodeDate(EY, EM, ED); Result := ComposeDateTime(Result, EncodeTime(EH, EN, ES, 0)); end; {$ENDIF} function TConnectionName.MySQLWriteData(AField: PMYSQL_FIELD; FieldDef: TFieldDef; Source, Dest: PChar; Len: integer; out CreateBlob : boolean): Boolean; var VI: Integer; VL: LargeInt; VS: Smallint; VW: Word; VO: LongWord; VF: Double; VC: Currency; VD: TDateTime; VB: TBCD; begin Result := False; CreateBlob := False; if Source = Nil then // If the pointer is NULL, the field is NULL exit; case FieldDef.DataType of ftSmallint: begin VS := InternalStrToInt(Source, Len); Move(VS, Dest^, SizeOf(Smallint)); end; ftWord: begin VW := InternalStrToInt(Source, Len); Move(VW, Dest^, SizeOf(Word)); end; ftInteger, ftAutoInc: begin VI := InternalStrToInt(Source, Len); Move(VI, Dest^, SizeOf(Integer)); end; ftLargeInt: begin {$IFDEF MYSQL50_UP} if AField^.ftype = FIELD_TYPE_BIT then begin VL := 0; for VI := 0 to Len-1 do VL := VL * 256 + PByte(Source+VI)^; end else {$ENDIF} VL := InternalStrToInt64(Source, Len); Move(VL, Dest^, SizeOf(LargeInt)); end; ftLongWord: begin VO := InternalStrToDWord(Source, Len); Move(VO, Dest^, SizeOf(LongWord)); end; ftFloat: begin VF := InternalStrToFloat(Source, Len); Move(VF, Dest^, SizeOf(Double)); end; ftBCD: begin VC := InternalStrToCurrency(Source, Len); Move(VC, Dest^, SizeOf(Currency)); end; ftFmtBCD: begin VB := InternalStrToBCD(Source, Len); Move(VB, Dest^, SizeOf(TBCD)); end; ftDate: begin VD := InternalStrToDate(Source, Len); Move(VD, Dest^, SizeOf(TDateTime)); end; ftTime: begin VD := InternalStrToTime(Source, Len); Move(VD, Dest^, SizeOf(TDateTime)); end; ftDateTime: begin {$IFDEF mysql40} if AField^.ftype = FIELD_TYPE_TIMESTAMP then VD := InternalStrToTimeStamp(Source, Len) else {$ENDIF} VD := InternalStrToDateTime(Source, Len); Move(VD, Dest^, SizeOf(TDateTime)); end; ftString, ftFixedChar: // String-fields which can contain more then dsMaxStringSize characters // are mapped to ftBlob fields, while their mysql-datatype is FIELD_TYPE_BLOB begin if Len > FieldDef.Size*FieldDef.CharSize then Len := FieldDef.Size*FieldDef.CharSize; Move(Source^, Dest^, Len); (Dest+Len)^ := #0; end; ftVarBytes: begin if Len > FieldDef.Size then Len := FieldDef.Size; PWord(Dest)^ := Len; Move(Source^, (Dest+sizeof(Word))^, Len); end; ftBytes: begin if Len > FieldDef.Size then Len := FieldDef.Size; Move(Source^, Dest^, Len); end; ftBlob, ftMemo: CreateBlob := True; end; Result := True; end; procedure TConnectionName.UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); var qry : TSQLQuery; begin if not assigned(Transaction) then DatabaseError(SErrConnTransactionnSet); qry := TSQLQuery.Create(nil); qry.Transaction := Transaction; qry.Database := Self; try with qry do begin ParseSQL := False; SQL.Clear; SQL.Add('show index from ' + TableName); Open; end; while not qry.Eof do with IndexDefs.AddIndexDef do begin Name := trim(qry.FieldByName('Key_name').AsString); Fields := trim(qry.FieldByName('Column_name').AsString); If Name = 'PRIMARY' then Options := Options + [ixPrimary]; If qry.FieldByName('Non_unique').AsInteger = 0 then Options := Options + [ixUnique]; qry.Next; while (Name = trim(qry.FieldByName('Key_name').AsString)) and (not qry.Eof) do begin Fields := Fields + ';' + trim(qry.FieldByName('Column_name').AsString); qry.Next; end; end; qry.Close; finally qry.Free; end; end; function TConnectionName.RowsAffected(cursor: TSQLCursor): TRowsCount; begin if assigned(cursor) then // Compile this without range-checking. RowsAffected can be -1, although // it's an unsigned integer. (small joke from the mysql-guys) // Without range-checking this goes ok. If Range is turned on, this results // in range-check errors. Result := (cursor as TCursorName).RowsAffected else Result := -1; end; function TConnectionName.RefreshLastInsertID(Query: TCustomSQLQuery; Field: TField): Boolean; begin Field.AsLargeInt:=GetInsertID; Result := True; end; constructor TConnectionName.Create(AOwner: TComponent); const SingleBackQoutes: TQuoteChars = ('`','`'); begin inherited Create(AOwner); FConnOptions := [sqEscapeRepeat, sqEscapeSlash, sqImplicitTransaction, sqLastInsertID]; FieldNameQuoteChars:=SingleBackQoutes; FMySQL := Nil; end; {$IFNDEF MYSQL50_UP} procedure TConnectionName.GetFieldNames(const TableName: string; List: TStrings); begin GetDBInfo(stColumns,TableName,'field',List); end; procedure TConnectionName.GetTableNames(List: TStrings; SystemTables: Boolean); begin GetDBInfo(stTables,'','tables_in_'+DatabaseName,List) end; {$ENDIF} function TConnectionName.GetConnectionInfo(InfoType: TConnInfoType): string; begin Result:=''; try InitialiseMysql; case InfoType of citServerType: Result:='MySQL'; citServerVersion: if Connected then Result:=format('%6.6d', [mysql_get_server_version(FMySQL)]); citServerVersionString: if Connected then Result:=mysql_get_server_info(FMySQL); citClientVersion: Result:=format('%6.6d', [mysql_get_client_version()]); citClientName: Result:=TMySQLConnectionDef.LoadedLibraryName; else Result:=inherited GetConnectionInfo(InfoType); end; finally ReleaseMysql; end; end; function TConnectionName.GetTransactionHandle(trans: TSQLHandle): pointer; begin Result:=Nil; end; function TConnectionName.Commit(trans: TSQLHandle): boolean; begin //mysql_commit(FMySQL); Result := (mysql_query(FMySQL, 'COMMIT') = 0) or ForcedClose; if not Result then MySQLError(FMySQL, SErrExecuting, Self); end; function TConnectionName.RollBack(trans: TSQLHandle): boolean; begin //mysql_rollback(FMySQL); Result := (mysql_query(FMySQL, 'ROLLBACK') = 0) or ForcedClose; if not Result then MySQLError(FMySQL, SErrExecuting, Self); end; function TConnectionName.StartdbTransaction(trans: TSQLHandle; AParams : string): boolean; begin Result := mysql_query(FMySQL, 'START TRANSACTION') = 0; if not Result then MySQLError(FMySQL, SErrExecuting, Self); end; procedure TConnectionName.CommitRetaining(trans: TSQLHandle); begin {$IFDEF MYSQL50_UP} if mysql_query(FMySQL, 'COMMIT AND CHAIN') <> 0 then MySQLError(FMySQL, SErrExecuting, Self); {$ELSE} if mysql_query(FMySQL, 'COMMIT') <> 0 then MySQLError(FMySQL, SErrExecuting, Self); if mysql_query(FMySQL, 'START TRANSACTION') <> 0 then MySQLError(FMySQL, SErrExecuting, Self); {$ENDIF} end; procedure TConnectionName.RollBackRetaining(trans: TSQLHandle); begin {$IFDEF MYSQL50_UP} if mysql_query(FMySQL, 'ROLLBACK AND CHAIN') <> 0 then MySQLError(FMySQL, SErrExecuting, Self); {$ELSE} if mysql_query(FMySQL, 'ROLLBACK') <> 0 then MySQLError(FMySQL, SErrExecuting, Self); if mysql_query(FMySQL, 'START TRANSACTION') <> 0 then MySQLError(FMySQL, SErrExecuting, Self); {$ENDIF} end; function TConnectionName.GetSchemaInfoSQL(SchemaType: TSchemaType; SchemaObjectName, SchemaPattern: string): string; begin case SchemaType of {$IFDEF MYSQL50_UP} stTables : result := 'SELECT * FROM INFORMATION_SCHEMA.TABLES WHERE TABLE_SCHEMA=SCHEMA() AND TABLE_TYPE IN (''BASE TABLE'',''VIEW'')'; stColumns : result := 'SELECT * FROM INFORMATION_SCHEMA.COLUMNS WHERE TABLE_SCHEMA=SCHEMA() AND TABLE_NAME='+QuotedStr(SchemaObjectName); {$ELSE} stTables : result := 'show tables'; stColumns : result := 'show columns from ' + EscapeString(SchemaObjectName); {$ENDIF} else result := inherited; end; {case} end; { TMySQLConnectionDef } class function TMySQLConnectionDef.TypeName: String; begin Result:='MySQL '+MySQLVersion; end; class function TMySQLConnectionDef.ConnectionClass: TSQLConnectionClass; begin {$IFDEF mysql80} Result:=TMySQL80Connection; {$ELSE} {$IFDEF mysql57} Result:=TMySQL57Connection; {$ELSE} {$IFDEF mysql56} Result:=TMySQL56Connection; {$ELSE} {$IfDef mysql55} Result:=TMySQL55Connection; {$ELSE} {$IfDef mysql51} Result:=TMySQL51Connection; {$ELSE} {$IfDef mysql50} Result:=TMySQL50Connection; {$ELSE} {$IfDef mysql41} Result:=TMySQL41Connection; {$ELSE} Result:=TMySQL40Connection; {$EndIf} {$EndIf} {$endif} {$endif} {$ENDIF} {$ENDIF} {$ENDIF} end; class function TMySQLConnectionDef.Description: String; begin Result:='Connect to a MySQL '+MySQLVersion+' database directly via the client library'; end; class function TMySQLConnectionDef.DefaultLibraryName: String; begin Result:=mysqlvlib; end; class function TMySQLConnectionDef.LoadFunction: TLibraryLoadFunction; begin Result:=@InitialiseMySQL; end; class function TMySQLConnectionDef.UnLoadFunction: TLibraryUnLoadFunction; begin Result:=@ReleaseMySQL; end; class function TMySQLConnectionDef.LoadedLibraryName: string; begin Result:=MysqlLoadedLibrary; end; {$IFDEF mysql80} initialization RegisterConnection(TMySQL80ConnectionDef); finalization UnRegisterConnection(TMySQL80ConnectionDef); {$ELSE} {$IFDEF mysql57} initialization RegisterConnection(TMySQL57ConnectionDef); finalization UnRegisterConnection(TMySQL57ConnectionDef); {$ELSE} {$IFDEF mysql56} initialization RegisterConnection(TMySQL56ConnectionDef); finalization UnRegisterConnection(TMySQL56ConnectionDef); {$ELSE} {$IfDef mysql55} initialization RegisterConnection(TMySQL55ConnectionDef); finalization UnRegisterConnection(TMySQL55ConnectionDef); {$else} {$IfDef mysql51} initialization RegisterConnection(TMySQL51ConnectionDef); finalization UnRegisterConnection(TMySQL51ConnectionDef); {$ELSE} {$IfDef mysql50} initialization RegisterConnection(TMySQL50ConnectionDef); finalization UnRegisterConnection(TMySQL50ConnectionDef); {$ELSE} {$IfDef mysql41} initialization RegisterConnection(TMySQL41ConnectionDef); finalization UnRegisterConnection(TMySQL41ConnectionDef); {$ELSE} initialization RegisterConnection(TMySQL40ConnectionDef); finalization UnRegisterConnection(TMySQL40ConnectionDef); {$EndIf} {$EndIf} {$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF} end.