diff --git a/packages/fcl-db/src/sqldb/mssql/mssqlconn.pp b/packages/fcl-db/src/sqldb/mssql/mssqlconn.pp index 200f6defcf..cb39ad7861 100644 --- a/packages/fcl-db/src/sqldb/mssql/mssqlconn.pp +++ b/packages/fcl-db/src/sqldb/mssql/mssqlconn.pp @@ -46,35 +46,34 @@ uses type - TServerInfo = record - ServerVersion: string; - ServerVersionString: string; - UserName: string; - end; - - TClientCharset = (ccNone, ccUTF8, ccISO88591, ccUnknown); - { TMSSQLConnection } TMSSQLConnection = class(TSQLConnection) private - FDBLogin: PLOGINREC; - FDBProc : PDBPROCESS; - Ftds : integer; // TDS protocol version - Fstatus : STATUS; // current result/rows fetch status - FServerInfo: TServerInfo; + type + TServerInfo = record + ServerVersion: string; + ServerVersionString: string; + UserName: string; + end; + var + FDBLogin: PLOGINREC; + FDBProc : PDBPROCESS; + Ftds : integer; // TDS protocol version + Fstatus : STATUS; // current result/rows fetch status + FServerInfo: TServerInfo; function CheckError(const Ret: RETCODE): RETCODE; procedure Execute(const cmd: string); overload; procedure ExecuteDirectSQL(const Query: string); procedure GetParameters(cursor: TSQLCursor; AParams: TParams); function TranslateFldType(SQLDataType: integer): TFieldType; - function ClientCharset: TClientCharset; function AutoCommit: boolean; function IsSybase: boolean; protected // Overrides from TSQLConnection function GetHandle:pointer; override; function GetAsSQLText(Param : TParam) : string; overload; override; + function GetConnectionCharSet: string; override; // - Connect/disconnect procedure DoInternalConnect; override; procedure DoInternalDisconnect; override; @@ -201,10 +200,10 @@ const var - DBErrorStr, DBMsgStr: string; + DBErrorStr, DBMsgStr: AnsiString; DBErrorNo, DBMsgNo: integer; -function DBErrHandler(dbproc: PDBPROCESS; severity, dberr, oserr:INT; dberrstr, oserrstr:PChar):INT; cdecl; +function DBErrHandler(dbproc: PDBPROCESS; severity, dberr, oserr:INT; dberrstr, oserrstr:PAnsiChar):INT; cdecl; begin DBErrorStr:=DBErrorStr+LineEnding+dberrstr; DBErrorNo :=dberr; @@ -212,7 +211,7 @@ begin // for server messages with severity greater than 10 error handler is also called end; -function DBMsgHandler(dbproc: PDBPROCESS; msgno: DBINT; msgstate, severity:INT; msgtext, srvname, procname:PChar; line:DBUSMALLINT):INT; cdecl; +function DBMsgHandler(dbproc: PDBPROCESS; msgno: DBINT; msgstate, severity:INT; msgtext, srvname, procname:PAnsiChar; line:DBUSMALLINT):INT; cdecl; begin DBMsgStr:=DBMsgStr+LineEnding+msgtext; DBMsgNo :=msgno; @@ -375,13 +374,7 @@ begin //if IsBinary(Param.AsString) then // Result := '0x' + StrToHex(Param.AsString) //else - begin - Result := QuotedStr(Param.AsString); - if (Ftds >= DBTDS_70) then - Result := 'N' + Result - else if (Ftds = 0) and (ClientCharset = ccUTF8) then //hack: Microsoft DB-Lib used - Result := UTF8Decode(Result); - end; + Result := 'N' + inherited GetAsSQLText(Param); ftBlob, ftBytes, ftVarBytes: Result := '0x' + StrToHex(Param.AsString); else @@ -391,6 +384,14 @@ begin Result:=inherited GetAsSQLText(Param); end; +function TMSSQLConnection.GetConnectionCharSet: string; +begin + if CharSet = '' then + Result := 'utf-8' + else + Result := CharSet; +end; + procedure TMSSQLConnection.DoInternalConnect; const DBVERSION: array[boolean] of BYTE = (DBVER60, DBVERSION_100); @@ -425,22 +426,22 @@ begin dbsetlsecure(FDBLogin) else begin - dbsetlname(FDBLogin, PChar(UserName), DBSETUSER); - dbsetlname(FDBLogin, PChar(Password), DBSETPWD); + dbsetlname(FDBLogin, PAnsiChar(UserName), DBSETUSER); + dbsetlname(FDBLogin, PAnsiChar(Password), DBSETPWD); end; if CharSet = '' then dbsetlcharset(FDBLogin, 'UTF-8') else - dbsetlcharset(FDBLogin, PChar(CharSet)); + dbsetlcharset(FDBLogin, PAnsiChar(CharSet)); if Params.IndexOfName(SAppName) <> -1 then - dbsetlname(FDBLogin, PChar(Params.Values[SAppName]), DBSETAPP); + dbsetlname(FDBLogin, PAnsiChar(Params.Values[SAppName]), DBSETAPP); - //dbsetlname(FDBLogin, PChar(TIMEOUT_IGNORE), DBSET_LOGINTIME); + //dbsetlname(FDBLogin, PAnsiChar(TIMEOUT_IGNORE), DBSET_LOGINTIME); dbsetlogintime(10); - FDBProc := dbopen(FDBLogin, PChar(HostName)); + FDBProc := dbopen(FDBLogin, PAnsiChar(HostName)); if FDBProc=nil then CheckError(FAIL); Ftds := dbtds(FDBProc); @@ -465,7 +466,7 @@ begin Execute(IMPLICIT_TRANSACTIONS_OFF[IsSybase]); //set connection to autocommit mode - default if DatabaseName <> '' then - CheckError( dbuse(FDBProc, PChar(DatabaseName)) ); + CheckError( dbuse(FDBProc, PAnsiChar(DatabaseName)) ); with TDBLibCursor.Create(Self) do begin @@ -562,27 +563,6 @@ begin Result := StrToBoolDef(Params.Values[SAutoCommit], False); end; -function TMSSQLConnection.ClientCharset: TClientCharset; -begin -{$IF (FPC_VERSION>=2) AND (FPC_RELEASE>4)} - case CharSet of - '' : Result := ccNone; - 'UTF-8' : Result := ccUTF8; - 'ISO-8859-1' : Result := ccISO88591; - else Result := ccUnknown; - end; -{$ELSE} - if CharSet = '' then - Result := ccNone - else if CharSet = 'UTF-8' then - Result := ccUTF8 - else if CharSet = 'ISO-8859-1' then - Result := ccISO88591 - else - Result := ccUnknown; -{$ENDIF} -end; - procedure TMSSQLConnection.PrepareStatement(cursor: TSQLCursor; ATransaction: TSQLTransaction; buf: string; AParams: TParams); begin @@ -599,7 +579,7 @@ procedure TMSSQLConnection.Execute(const cmd: string); begin DBErrorStr:=''; DBMsgStr :=''; - CheckError( dbcmd(FDBProc, PChar(cmd)) ); + CheckError( dbcmd(FDBProc, PAnsiChar(cmd)) ); CheckError( dbsqlexec(FDBProc) ); CheckError( dbresults(FDBProc) ); end; @@ -731,7 +711,6 @@ begin FieldSize := col.MaxLength; if FieldSize >= $3FFFFFFF then // varchar(max) FieldType := ftMemo; - end; ftBytes, ftVarBytes: begin @@ -753,15 +732,8 @@ begin FieldType := ftAutoInc; end; - with FieldDefs.Add(FieldDefs.MakeNameUnique(FieldName), FieldType, FieldSize, (col.Null=0) and (not col.Identity), i) do - begin - // identity, timestamp and calculated column are not updatable - if col.Updatable = 0 then Attributes := Attributes + [faReadonly]; - case FieldType of - ftBCD, - ftFmtBCD: Precision := col.Precision; - end; - end; + // identity, timestamp and calculated column are not updatable + AddFieldDef(FieldDefs, i, FieldName, FieldType, FieldSize, col.Precision, True, (col.Null=0) and (not col.Identity), col.Updatable=0); end; end; @@ -787,7 +759,7 @@ var i: integer; dbdt: DBDATETIME; dbdr: DBDATEREC; dbdta: DBDATETIMEALL; - bcdstr: array[0..MaxFmtBCDFractionSize+2] of char; + bcdstr: array[0..MaxFmtBCDFractionSize+2] of AnsiChar; begin CreateBlob:=false; i:=FieldDef.FieldNo; @@ -803,7 +775,10 @@ begin destlen:=FieldDef.Size; case FieldDef.DataType of ftString, ftFixedChar: + begin desttype:=SQLCHAR; + destlen:=FieldDef.Size*FieldDef.CharSize; + end; ftBytes: desttype:=SQLBINARY; ftVarBytes: @@ -893,12 +868,7 @@ begin case FieldDef.DataType of ftString, ftFixedChar: - begin - PChar(dest + datalen)^ := #0; //strings must be null-terminated - if ((Ftds = 0) and (ClientCharset = ccUTF8)) {hack: MS DB-Lib used} or - (ClientCharset = ccISO88591) {hack: FreeTDS} then - StrPLCopy(PChar(dest), UTF8Encode(PChar(dest)), destlen); - end; + PAnsiChar(dest + datalen)^ := #0; //strings must be null-terminated ftDate, ftTime, ftDateTime: if desttype = SYBMSDATETIME2 then PDateTime(buffer)^ := dbdatetimeallcrack(@dbdta) diff --git a/packages/fcl-db/src/sqldb/sqldb.pp b/packages/fcl-db/src/sqldb/sqldb.pp index a1a2a17658..80f0078787 100644 --- a/packages/fcl-db/src/sqldb/sqldb.pp +++ b/packages/fcl-db/src/sqldb/sqldb.pp @@ -190,6 +190,7 @@ type FUserName : string; FHostName : string; FCharSet : string; + FCodePage : TSystemCodePage; FRole : String; FStatements : TFPList; FLogEvents: TDBEventTypes; @@ -218,9 +219,12 @@ type procedure ApplyRecUpdate(Query : TCustomSQLQuery; UpdateKind : TUpdateKind); virtual; function RefreshLastInsertID(Query : TCustomSQLQuery; Field : TField): Boolean; virtual; procedure GetDBInfo(const ASchemaType : TSchemaType; const ASchemaObjectName, AReturnField : string; AList: TStrings); + function GetConnectionCharSet: string; virtual; procedure SetTransaction(Value : TSQLTransaction); virtual; + procedure DoConnect; override; procedure DoInternalConnect; override; procedure DoInternalDisconnect; override; + function GetAsString(Param: TParam): RawByteString; function GetAsSQLText(Field : TField) : string; overload; virtual; function GetAsSQLText(Param : TParam) : string; overload; virtual; function GetHandle : pointer; virtual; @@ -229,6 +233,7 @@ type Procedure Log(EventType : TDBEventType; Const Msg : String); virtual; Procedure RegisterStatement(S : TCustomSQLStatement); Procedure UnRegisterStatement(S : TCustomSQLStatement); + Function AllocateCursorHandle : TSQLCursor; virtual; abstract; Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); virtual; abstract; function StrToStatementType(s : string) : TStatementType; virtual; @@ -237,7 +242,8 @@ type procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); virtual; abstract; function RowsAffected(cursor: TSQLCursor): TRowsCount; virtual; function Fetch(cursor : TSQLCursor) : boolean; virtual; abstract; - procedure AddFieldDefs(cursor: TSQLCursor; FieldDefs : TfieldDefs); virtual; abstract; + procedure AddFieldDefs(cursor: TSQLCursor; FieldDefs : TFieldDefs); virtual; abstract; + function AddFieldDef(AFieldDefs: TFieldDefs; AFieldNo: Longint; const AName: string; ADataType: TFieldType; ASize, APrecision: Integer; AByteSize, ARequired, AReadOnly: Boolean): TFieldDef; function LoadField(cursor : TSQLCursor; FieldDef : TFieldDef; buffer : pointer; out CreateBlob : boolean) : boolean; virtual; abstract; procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); virtual; abstract; procedure FreeFldBuffers(cursor : TSQLCursor); virtual; @@ -697,8 +703,8 @@ type Property DataBase : TDatabase Read FDatabase Write SetDatabase; Property Transaction : TDBTransaction Read FTransaction Write SetTransaction; property OnDirective: TSQLScriptDirectiveEvent read FOnDirective write FOnDirective; - Property UseDollarString; - Property DollarStrings; + Property UseDollarString; + Property DollarStrings; property Directives; property Defines; property Script; @@ -1213,16 +1219,40 @@ begin end; end; - procedure TSQLConnection.UpdateIndexDefs(IndexDefs : TIndexDefs; TableName : string); begin // Empty abstract end; +procedure TSQLConnection.DoConnect; +var ConnectionCharSet: string; +begin + inherited; + + // map connection CharSet to corresponding local CodePage + // do not set FCodePage to CP_ACP if FCodePage = DefaultSystemCodePage + // aliases listed here are commonly used, but not recognized by CodePageNameToCodePage() + ConnectionCharSet := LowerCase(GetConnectionCharSet); + case ConnectionCharSet of + 'utf8','utf-8': + FCodePage := CP_UTF8; + 'win1250','cp1250': + FCodePage := 1250; + 'win1252','cp1252','latin1','iso8859_1': + FCodePage := 1252; + else + begin + FCodePage := CodePageNameToCodePage(ConnectionCharSet); + if FCodePage = CP_NONE then + FCodePage := CP_ACP; + end; + end; +end; + procedure TSQLConnection.DoInternalConnect; begin if (DatabaseName = '') and not(sqSupportEmptyDatabaseName in FConnOptions) then - DatabaseError(SErrNoDatabaseName,self); + DatabaseError(SErrNoDatabaseName,Self); end; procedure TSQLConnection.DoInternalDisconnect; @@ -1366,11 +1396,43 @@ begin end; end; +function TSQLConnection.GetConnectionCharSet: string; +begin + // default implementation returns user supplied FCharSet + // (can be overriden by descendants, which are able retrieve current connection charset using client API) + Result := FCharSet; +end; + function TSQLConnection.RowsAffected(cursor: TSQLCursor): TRowsCount; begin Result := -1; end; +function TSQLConnection.AddFieldDef(AFieldDefs: TFieldDefs; AFieldNo: Longint; + const AName: string; ADataType: TFieldType; ASize, APrecision: Integer; + AByteSize, ARequired, AReadOnly: Boolean): TFieldDef; +var + ACodePage: TSystemCodePage; +begin + // helper function used by descendants + if ADataType in [ftString, ftFixedChar, ftMemo] then + begin + ACodePage := FCodePage; + // if ASize of character data is passed as "byte length", + // translate it to "character length" as expected by TFieldDef + if AByteSize and (ACodePage = CP_UTF8) then + ASize := ASize div 4; + end + else + ACodePage := 0; + Result := AFieldDefs.Add(AFieldDefs.MakeNameUnique(AName), ADataType, ASize, ARequired, AFieldNo, ACodePage); + if AReadOnly then + Result.Attributes := Result.Attributes + [faReadOnly]; + case ADataType of + ftBCD, ftFmtBCD: + Result.Precision := APrecision; + end; +end; procedure TSQLConnection.GetTableNames(List: TStrings; SystemTables: Boolean); begin @@ -1623,6 +1685,20 @@ begin until CurrentP^=#0; end; +function TSQLConnection.GetAsString(Param: TParam): RawByteString; +begin + // converts parameter value to connection charset + if FCodePage = CP_UTF8 then + Result := Param.AsUTF8String + else if FCodePage in [DefaultSystemCodePage, CP_ACP] then + Result := Param.AsAnsiString + else + begin + Result := Param.AsAnsiString; + SetCodePage(Result, FCodePage, True); + end; +end; + function TSQLConnection.GetAsSQLText(Field : TField) : string; begin if (not assigned(Field)) or Field.IsNull then Result := 'Null' @@ -1643,14 +1719,14 @@ begin ftGuid, ftMemo, ftFixedChar, - ftString : Result := QuotedStr(Param.AsString); + ftString : Result := QuotedStr(GetAsString(Param)); ftDate : Result := '''' + FormatDateTime('yyyy-mm-dd',Param.AsDateTime,FSQLFormatSettings) + ''''; ftTime : Result := QuotedStr(TimeIntervalToString(Param.AsDateTime)); ftDateTime : Result := '''' + FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz', Param.AsDateTime, FSQLFormatSettings) + ''''; ftCurrency, ftBcd : Result := CurrToStr(Param.AsCurrency, FSQLFormatSettings); ftFloat : Result := FloatToStr(Param.AsFloat, FSQLFormatSettings); - ftFMTBcd : Result := stringreplace(Param.AsString, DefaultFormatSettings.DecimalSeparator, FSQLFormatSettings.DecimalSeparator, []); + ftFMTBcd : Result := StringReplace(Param.AsString, DefaultFormatSettings.DecimalSeparator, FSQLFormatSettings.DecimalSeparator, []); else Result := Param.AsString; end; {case} diff --git a/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp b/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp index efbbc67201..2d11f71fa7 100644 --- a/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp +++ b/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp @@ -53,7 +53,8 @@ type procedure DoInternalConnect; override; procedure DoInternalDisconnect; override; function GetHandle : pointer; override; - + function GetConnectionCharSet: string; override; + Function AllocateCursorHandle : TSQLCursor; override; Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override; Function AllocateTransactionHandle : TSQLHandle; override; @@ -148,7 +149,7 @@ type procedure freebindstring(astring: pointer); cdecl; begin - StrDispose(AString); + StrDispose(astring); end; procedure TSQLite3Cursor.checkerror(const aerror: integer); @@ -158,8 +159,7 @@ end; Procedure TSQLite3Cursor.bindparams(AParams : TParams); - Function PCharStr(Const S : String) : PChar; - + Function PAllocStr(Const S : RawByteString) : PAnsiChar; begin Result:=StrAlloc(Length(S)+1); If (Result<>Nil) then @@ -168,9 +168,10 @@ Procedure TSQLite3Cursor.bindparams(AParams : TParams); Var I : Integer; - P : TParam; - str1: string; - wstr1: widestring; + P : TParam; + astr: AnsiString; + ustr: UTF8String; + wstr: WideString; begin for I:=1 to high(fparambinding)+1 do @@ -194,25 +195,27 @@ begin ftTime: checkerror(sqlite3_bind_double(fstatement, I, P.AsFloat - JulianEpoch)); ftFMTBcd: begin - str1:=BCDToStr(P.AsFMTBCD, Fconnection.FSQLFormatSettings); - checkerror(sqlite3_bind_text(fstatement, I, PChar(str1), length(str1), sqlite3_destructor_type(SQLITE_TRANSIENT))); + astr:=BCDToStr(P.AsFMTBCD, Fconnection.FSQLFormatSettings); + checkerror(sqlite3_bind_text(fstatement, I, PAnsiChar(astr), length(astr), sqlite3_destructor_type(SQLITE_TRANSIENT))); end; ftString, ftFixedChar, ftMemo: begin // According to SQLite documentation, CLOB's (ftMemo) have the Text affinity - str1:= p.asstring; - checkerror(sqlite3_bind_text(fstatement,I,pcharstr(str1), length(str1),@freebindstring)); + ustr:= P.AsUTF8String; + checkerror(sqlite3_bind_text(fstatement,I, PAllocStr(ustr), length(ustr), @freebindstring)); end; ftBytes, ftVarBytes, ftBlob: begin - str1:= P.asstring; - checkerror(sqlite3_bind_blob(fstatement,I,pcharstr(str1), length(str1),@freebindstring)); + astr:= P.AsAnsiString; + checkerror(sqlite3_bind_blob(fstatement,I, PAllocStr(astr), length(astr), @freebindstring)); end; - ftWideString, ftFixedWideChar, ftWideMemo: + ftWideString, + ftFixedWideChar, + ftWideMemo: begin - wstr1:=P.AsWideString; - checkerror(sqlite3_bind_text16(fstatement,I, PWideChar(wstr1), length(wstr1)*sizeof(WideChar), sqlite3_destructor_type(SQLITE_TRANSIENT))); + wstr:=P.AsWideString; + checkerror(sqlite3_bind_text16(fstatement,I, PWideChar(wstr), length(wstr)*sizeof(WideChar), sqlite3_destructor_type(SQLITE_TRANSIENT))); end else DatabaseErrorFmt(SUnsupportedParameter, [Fieldtypenames[P.DataType], Self]); @@ -240,21 +243,8 @@ end; Procedure TSQLite3Cursor.Execute; -var - wo1: word; - begin -{$ifdef i386} - wo1:= get8087cw; - set8087cw(wo1 or $1f); //mask exceptions, Sqlite3 has overflow - Try // Why do people always forget this ?? -{$endif} - fstate:= sqlite3_step(fstatement); -{$ifdef i386} - finally - set8087cw(wo1); //restore - end; -{$endif} + fstate:= sqlite3_step(fstatement); if (fstate<=sqliteerrormax) then checkerror(sqlite3_reset(fstatement)); FSelectable :=sqlite3_column_count(fstatement)>0; @@ -296,7 +286,7 @@ var begin st:=TSQLite3Cursor(cursor).fstatement; - fnum:= FieldDef.fieldno - 1; + fnum:= FieldDef.FieldNo - 1; case FieldDef.DataType of ftWideMemo: @@ -510,7 +500,7 @@ begin end; ftUnknown : DatabaseErrorFmt('Unknown or unsupported data type %s of column %s', [FD, FN]); end; // Case - FieldDefs.Add(FieldDefs.MakeNameUnique(FN),ft1,size1,false,i+1); + FieldDefs.Add(FieldDefs.MakeNameUnique(FN), ft1, size1, false, i+1, CP_UTF8); end; end; @@ -666,8 +656,8 @@ begin ftFixedChar, ftString: begin int1:= sqlite3_column_bytes(st,fnum); - if int1>FieldDef.Size then - int1:=FieldDef.Size; + if int1>FieldDef.Size*FieldDef.CharSize then + int1:=FieldDef.Size*FieldDef.CharSize; if int1 > 0 then move(sqlite3_column_text(st,fnum)^,buffer^,int1); PAnsiChar(buffer + int1)^ := #0; @@ -799,6 +789,11 @@ begin result:= fhandle; end; +function TSQLite3Connection.GetConnectionCharSet: string; +begin + Result:='utf8'; +end; + procedure TSQLite3Connection.checkerror(const aerror: integer); Var