1unit IBConnection; 2 3{$mode objfpc}{$H+} 4 5{$Define LinkDynamically} 6 7interface 8 9uses 10 Classes, SysUtils, sqldb, db, dbconst, bufdataset, 11{$IfDef LinkDynamically} 12 ibase60dyn; 13{$Else} 14 ibase60; 15{$EndIf} 16 17const 18 DEFDIALECT = 3; 19 MAXBLOBSEGMENTSIZE = 65535; //Maximum number of bytes that fit in a blob segment. 20 21type 22 TDatabaseInfo = record 23 Dialect : integer; //Dialect set in database 24 ODSMajorVersion : integer; //On-Disk Structure version of file 25 ServerVersion : string; //Representation of major.minor (.build) 26 ServerVersionString : string; //Complete version string, including name, platform 27 end; 28 29 TStatusVector = array [0..19] of ISC_STATUS; 30 31 { EIBDatabaseError } 32 33 EIBDatabaseError = class(ESQLDatabaseError) 34 private 35 FStatusVector: TStatusVector; 36 public 37 Property StatusVector: TStatusVector Read FStatusVector Write FStatusVector; 38 property GDSErrorCode: integer read ErrorCode; deprecated 'Please use ErrorCode instead of GDSErrorCode'; // Nov 2014 39 end; 40 41 { TIBCursor } 42 43 TIBCursor = Class(TSQLCursor) 44 protected 45 Status : TStatusVector; 46 TransactionHandle : pointer; 47 StatementHandle : pointer; 48 SQLDA : PXSQLDA; 49 in_SQLDA : PXSQLDA; 50 ParamBinding : array of integer; 51 FieldBinding : array of integer; 52 end; 53 54 TIBTrans = Class(TSQLHandle) 55 protected 56 TransactionHandle : pointer; 57 TPB : string; // Transaction parameter buffer 58 Status : TStatusVector; 59 end; 60 61 { TIBConnection } 62 63 TIBConnection = class (TSQLConnection) 64 private 65 FCheckTransactionParams: Boolean; 66 FDatabaseHandle : pointer; 67 FStatus : TStatusVector; 68 FDatabaseInfo : TDatabaseInfo; 69 FDialect : integer; 70 FBlobSegmentSize : word; //required for backward compatibilty; not used 71 FUseConnectionCharSetIfNone: Boolean; 72 FWireCompression : Boolean; 73 procedure ConnectFB; 74 75 procedure AllocSQLDA(var aSQLDA : PXSQLDA;Count : integer); 76 77 // Metadata: 78 procedure GetDatabaseInfo; //Queries for various information from server once connected 79 function InterpretTransactionParam(S: String; var TPB: AnsiChar; out AValue: String): Boolean; 80 procedure ResetDatabaseInfo; //Useful when disconnecting 81 function GetDialect: integer; 82 function GetODSMajorVersion: integer; 83 function ParseServerVersion(const CompleteVersion: string): string; //Extract version info from complete version identification string 84 85 // conversion methods 86 procedure TranslateFldType(SQLType, SQLSubType, SQLLen, SQLScale : integer; 87 out TrType : TFieldType; out TrLen, TrPrec : word); 88 procedure GetDateTime(CurrBuff, Buffer : pointer; AType : integer); 89 procedure SetDateTime(CurrBuff: pointer; PTime : TDateTime; AType : integer); 90 procedure GetFloat(CurrBuff, Buffer : pointer; Size : Byte); 91 procedure SetFloat(CurrBuff: pointer; Dbl: Double; Size: integer); 92 93 procedure CheckError(ProcName : string; Status : PISC_STATUS); 94 procedure SetParameters(cursor : TSQLCursor; aTransation : TSQLTransaction; AParams : TParams); 95 procedure FreeSQLDABuffer(var aSQLDA : PXSQLDA); 96 function IsDialectStored: boolean; 97 protected 98 procedure DoConnect; override; 99 procedure DoInternalConnect; override; 100 procedure DoInternalDisconnect; override; 101 function GetHandle : pointer; override; 102 103 Function AllocateCursorHandle : TSQLCursor; override; 104 Procedure DeAllocateCursorHandle(var cursor : TSQLCursor); override; 105 Function AllocateTransactionHandle : TSQLHandle; override; 106 107 procedure PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); override; 108 procedure UnPrepareStatement(cursor : TSQLCursor); override; 109 procedure FreeFldBuffers(cursor : TSQLCursor); override; 110 procedure Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); override; 111 procedure AddFieldDefs(cursor: TSQLCursor;FieldDefs : TFieldDefs); override; 112 function Fetch(cursor : TSQLCursor) : boolean; override; 113 function LoadField(cursor : TSQLCursor;FieldDef : TfieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; override; 114 function GetTransactionHandle(trans : TSQLHandle): pointer; override; 115 function Commit(trans : TSQLHandle) : boolean; override; 116 function RollBack(trans : TSQLHandle) : boolean; override; 117 function StartDBTransaction(trans : TSQLHandle; AParams : string) : boolean; override; 118 procedure CommitRetaining(trans : TSQLHandle); override; 119 procedure RollBackRetaining(trans : TSQLHandle); override; 120 procedure UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); override; 121 procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); override; 122 function RowsAffected(cursor: TSQLCursor): TRowsCount; override; 123 function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override; 124 function GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string; override; 125 public 126 constructor Create(AOwner : TComponent); override; 127 function GetConnectionInfo(InfoType:TConnInfoType): string; override; 128 procedure CreateDB; override; 129 procedure DropDB; override; 130 // Segment size is not used in the code; property kept for backward compatibility 131 property BlobSegmentSize : word read FBlobSegmentSize write FBlobSegmentSize; deprecated; 132 property ODSMajorVersion : integer read GetODSMajorVersion; //ODS major version number; influences database compatibility/feature level. 133 published 134 property DatabaseName; 135 property Dialect : integer read GetDialect write FDialect stored IsDialectStored default DEFDIALECT; 136 // Set this to true to have StartTransaction check transaction parameters. If False, unknown parameters are ignored. 137 Property CheckTransactionParams : Boolean Read FCheckTransactionParams write FCheckTransactionParams; 138 property KeepConnection; 139 property LoginPrompt; 140 property Params; 141 property OnLogin; 142 Property Port stored false; 143 Property UseConnectionCharSetIfNone : Boolean Read FUseConnectionCharSetIfNone Write FUseConnectionCharSetIfNone; 144 property WireCompression: Boolean read FWireCompression write FWireCompression default False; 145 end; 146 147 { TIBConnectionDef } 148 149 TIBConnectionDef = Class(TConnectionDef) 150 Class Function TypeName : String; override; 151 Class Function ConnectionClass : TSQLConnectionClass; override; 152 Class Function Description : String; override; 153 Class Function DefaultLibraryName : String; override; 154 Class Function LoadFunction : TLibraryLoadFunction; override; 155 Class Function UnLoadFunction : TLibraryUnLoadFunction; override; 156 Class Function LoadedLibraryName: string; override; 157 end; 158 159implementation 160 161uses 162 StrUtils, FmtBCD; 163 164const 165 SQL_BOOLEAN_INTERBASE = 590; 166 SQL_BOOLEAN_FIREBIRD = 32764; 167 SQL_NULL = 32767; 168 INVALID_DATA = -1; 169 170procedure TIBConnection.CheckError(ProcName : string; Status : PISC_STATUS); 171var 172 i,ErrorCode : longint; 173 Msg, SQLState : string; 174 Buf : array [0..1023] of char; 175 aStatusVector: TStatusVector; 176 Exc : EIBDatabaseError; 177 178begin 179 if ((Status[0] = 1) and (Status[1] <> 0)) then 180 begin 181 ErrorCode := Status[1]; 182{$IFDEF LinkDynamically} 183 if assigned(fb_sqlstate) then // >= Firebird 2.5 184 begin 185 fb_sqlstate(Buf, Status); 186 SQLState := StrPas(Buf); 187 end; 188{$ENDIF} 189 { get a local copy of status vector } 190 for i := 0 to 19 do 191 aStatusVector[i] := Status[i]; 192 Msg := ''; 193 while isc_interprete(Buf, @Status) > 0 do 194 Msg := Msg + LineEnding + ' -' + StrPas(Buf); 195 Exc:=EIBDatabaseError.CreateFmt('%s : %s', [ProcName,Msg], Self, ErrorCode, SQLState); 196 Exc.StatusVector:=aStatusVector; 197 raise Exc; 198 end; 199end; 200 201 202constructor TIBConnection.Create(AOwner : TComponent); 203 204begin 205 inherited; 206 FConnOptions := FConnOptions + [sqSupportParams, sqEscapeRepeat, sqSupportReturning, sqSequences]; 207 FBlobSegmentSize := 65535; //Shows we're using the maximum segment size 208 FDialect := INVALID_DATA; 209 FWireCompression := False; 210 ResetDatabaseInfo; 211end; 212 213 214function TIBConnection.GetTransactionHandle(trans : TSQLHandle): pointer; 215begin 216 if Assigned(trans) then 217 Result := (trans as TIBTrans).TransactionHandle 218 else 219 Result := nil; 220end; 221 222function TIBConnection.Commit(trans : TSQLHandle) : boolean; 223begin 224 result := false; 225 with (trans as TIBTrans) do 226 if isc_commit_transaction(@Status[0], @TransactionHandle) <> 0 then 227 CheckError('Commit', Status) 228 else result := true; 229end; 230 231function TIBConnection.RollBack(trans : TSQLHandle) : boolean; 232begin 233 result := false; 234 if isc_rollback_transaction(@TIBTrans(trans).Status[0], @TIBTrans(trans).TransactionHandle) <> 0 then 235 CheckError('Rollback', TIBTrans(trans).Status) 236 else result := true; 237end; 238 239function TIBConnection.InterpretTransactionParam(S: String; var TPB: AnsiChar; 240 out AValue: String): Boolean; 241 242Const 243 Prefix = 'isc_tpb_'; 244 PrefixLen = Length(Prefix); 245 maxParam = 21; 246 TPBNames : Array[1..maxParam] Of String = 247 // 5 on a line. Lowercase 248 ('consistency','concurrency','shared','protected','exclusive', 249 'wait','nowait','read','write','lock_read', 250 'lock_write','verb_time','commit_time','ignore_limbo','read_committed', 251 'autocommit','rec_version','no_rec_version','restart_requests','no_auto_undo', 252 'lock_timeout'); 253 254Var 255 P : Integer; 256 257begin 258 TPB:=#0; 259 Result:=False; 260 P:=Pos('=',S); 261 If P<>0 then 262 begin 263 AValue:=Copy(S,P+1,Length(S)-P); 264 S:=Copy(S,1,P-1); 265 end; 266 S:=LowerCase(S); 267 P:=Pos(Prefix,S); 268 if P<>0 then 269 Delete(S,1,P+PrefixLen-1); 270 Result:=(Copy(S,1,7)='version') and (Length(S)=8); 271 if Result then 272 TPB:=S[8] 273 else 274 begin 275 P:=MaxParam; 276 While (P>0) and (S<>TPBNames[P]) do 277 Dec(P); 278 Result:=P>0; 279 if Result then 280 TPB:=Char(P); 281 end; 282end; 283 284function TIBConnection.StartDBTransaction(trans: TSQLHandle; AParams: string 285 ): boolean; 286 287Var 288 DBHandle:pointer; 289 I : integer; 290 S :string; 291 tpbv,version : ansichar; 292 prVal :String; 293 pInt :^Int32; 294 LTPB : String; // Local TPB 295 IBTrans : TIBTrans; 296 297Begin 298 Result:=False; 299 DBHandle:=GetHandle; 300 Version:=#0; 301 I:=1; 302 IBTrans:=(Trans as TIBTrans); 303 LTPB:=''; 304 S:=ExtractSubStr(AParams,I,stdWordDelims); 305 While (S<>'') do 306 begin 307 If Not InterpretTransactionParam(S,tpbv,prVal) then 308 begin 309 If CheckTransactionParams then 310 DatabaseError('Invalid parameter for transaction: "'+S+'"',Self); 311 end 312 else 313 begin 314 // Check Version 315 if (tpbv>='1') then 316 begin 317 Version:=tpbv; 318 // Check value 319 if Not (Version in ['1','3']) then 320 DatabaseError('Invalid version specified for transaction: "'+Version+'"',Self); 321 end 322 else 323 begin 324 LTPB:=LTPB+tpbv; 325 Case Ord(tpbv) Of 326 isc_tpb_lock_read, 327 isc_tpb_lock_write: 328 Begin 329 If prVal='' Then 330 DatabaseErrorFmt('Table name must be specified for "%s"',[S],Self); 331 LTPB:=LTPB+Char(Length(prVal))+prVal; 332 End; 333 isc_tpb_lock_timeout: 334 Begin 335 //In case of using lock timeout we need add timeout 336 If prVal='' Then 337 DatabaseErrorFmt('Timeout must be specified for "%s"',[S],Self); 338 LTPB:=LTPB+Char(SizeOf(ISC_LONG)); 339 SetLength(LTPB,Length(LTPB)+SizeOf(ISC_LONG)); 340 pInt:=@LTPB[Length(LTPB)-SizeOf(ISC_LONG)+1]; 341 pInt^:=StrToInt(prVal); 342 End; 343 End; 344 end; 345 end; 346 S:=ExtractSubStr(AParams,I,stdWordDelims); 347 end; 348 // Default version. 349 If Version=#0 then 350 Version:='3'; 351 // Construct block. 352 With IBTrans do 353 begin 354 TPB:=Char(Ord(Version)-Ord('0'))+LTPB; 355 TransactionHandle:=Nil; 356 If isc_start_transaction(@Status[0],@TransactionHandle,1,[@DBHandle,Length(TPB),@TPB[1]])<>0 Then 357 CheckError('StartTransaction',Status) 358 Else 359 Result := True 360 End 361End; 362 363procedure TIBConnection.CommitRetaining(trans : TSQLHandle); 364begin 365 with trans as TIBtrans do 366 if isc_commit_retaining(@Status[0], @TransactionHandle) <> 0 then 367 CheckError('CommitRetaining', Status); 368end; 369 370procedure TIBConnection.RollBackRetaining(trans : TSQLHandle); 371begin 372 with trans as TIBtrans do 373 if isc_rollback_retaining(@Status[0], @TransactionHandle) <> 0 then 374 CheckError('RollBackRetaining', Status); 375end; 376 377 378procedure TIBConnection.DropDB; 379 380begin 381 CheckDisConnected; 382 383{$IfDef LinkDynamically} 384 InitialiseIBase60; 385{$EndIf} 386 387 ConnectFB; 388 389 if isc_drop_database(@FStatus[0], @FDatabaseHandle) <> 0 then 390 CheckError('DropDB', FStatus); 391 392{$IfDef LinkDynamically} 393 ReleaseIBase60; 394{$EndIf} 395end; 396 397 398procedure TIBConnection.CreateDB; 399 400var ASQLDatabaseHandle, 401 ASQLTransactionHandle : pointer; 402 CreateSQL : String; 403 pagesize : String; 404begin 405 CheckDisConnected; 406{$IfDef LinkDynamically} 407 InitialiseIBase60; 408{$EndIf} 409 ASQLDatabaseHandle := nil; 410 ASQLTransactionHandle := nil; 411 412 CreateSQL := 'CREATE DATABASE '; 413 if HostName <> '' then 414 CreateSQL := CreateSQL + ''''+ HostName+':'+DatabaseName + '''' 415 else 416 CreateSQL := CreateSQL + '''' + DatabaseName + ''''; 417 if UserName <> '' then 418 CreateSQL := CreateSQL + ' USER ''' + Username + ''''; 419 if Password <> '' then 420 CreateSQL := CreateSQL + ' PASSWORD ''' + Password + ''''; 421 pagesize := Params.Values['PAGE_SIZE']; 422 if pagesize <> '' then 423 CreateSQL := CreateSQL + ' PAGE_SIZE '+pagesize; 424 if CharSet <> '' then 425 CreateSQL := CreateSQL + ' DEFAULT CHARACTER SET ' + CharSet; 426 427 if isc_dsql_execute_immediate(@FStatus[0],@ASQLDatabaseHandle,@ASQLTransactionHandle,length(CreateSQL),@CreateSQL[1],Dialect,nil) <> 0 then 428 CheckError('CreateDB', FStatus); 429 430 if isc_detach_database(@FStatus[0], @ASQLDatabaseHandle) <> 0 then 431 CheckError('CreateDB', FStatus); 432{$IfDef LinkDynamically} 433 ReleaseIBase60; 434{$EndIf} 435end; 436 437procedure TIBConnection.DoInternalConnect; 438begin 439{$IfDef LinkDynamically} 440 InitialiseIBase60; 441{$EndIf} 442 inherited dointernalconnect; 443 444 ConnectFB; 445end; 446 447procedure TIBConnection.DoInternalDisconnect; 448begin 449 Inherited; 450 FDialect := INVALID_DATA; 451 if not Connected then 452 begin 453 ResetDatabaseInfo; 454 FDatabaseHandle := nil; 455 Exit; 456 end; 457 458 if isc_detach_database(@FStatus[0], @FDatabaseHandle) <> 0 then 459 CheckError('Close', FStatus); 460{$IfDef LinkDynamically} 461 ReleaseIBase60; 462{$ELSE} 463 // Shutdown embedded subsystem with timeout 300ms (Firebird 2.5+) 464 // Required before unloading library; has no effect on non-embedded client 465 if (pointer(fb_shutdown)<>nil) and (fb_shutdown(300,1)<>0) then 466 begin 467 //todo: log error; still try to unload library below as the timeout may have been insufficient 468 end; 469{$EndIf} 470end; 471 472function TIBConnection.GetConnectionInfo(InfoType: TConnInfoType): string; 473begin 474 result:=''; 475 {$IFDEF LinkDynamically} 476 InitialiseIBase60; 477 {$ENDIF} 478 try 479 case InfoType of 480 citServerType: 481 // Firebird returns own name in ServerVersion; Interbase 7.5 doesn't. 482 if Pos('Firebird', FDatabaseInfo.ServerVersionString)=0 then 483 result := 'Interbase' 484 else 485 result := 'Firebird'; 486 citServerVersion: 487 // Firebird returns major.minor, Interbase major.minor.build 488 result := FDatabaseInfo.ServerVersion; 489 citServerVersionString: 490 result := FDatabaseInfo.ServerVersionString; 491 citClientName: 492 result:=TIBConnectionDef.LoadedLibraryName; 493 else 494 //including citClientVersion, for which no single IB+FB and Win+*nux solution exists 495 result:=inherited GetConnectionInfo(InfoType); 496 end; 497 finally 498 {$IFDEF LinkDynamically} 499 ReleaseIBase60; 500 {$ENDIF} 501 end; 502end; 503 504procedure TIBConnection.GetDatabaseInfo; 505// Asks server for multiple values 506const 507 ResBufHigh = 512; //hopefully enough to include version string as well. 508var 509 x : integer; 510 Len : integer; 511 ReqBuf : array [0..3] of byte; 512 ResBuf : array [0..ResBufHigh] of byte; // should be big enough for version string etc 513begin 514 ResetDatabaseInfo; 515 if Connected then 516 begin 517 ReqBuf[0] := isc_info_ods_version; 518 ReqBuf[1] := isc_info_version; 519 ReqBuf[2] := isc_info_db_sql_dialect; 520 ReqBuf[3] := isc_info_end; 521 if isc_database_info(@FStatus[0], @FDatabaseHandle, Length(ReqBuf), 522 pchar(@ReqBuf[0]), SizeOf(ResBuf), pchar(@ResBuf[0])) <> 0 then 523 CheckError('CacheServerInfo', FStatus); 524 x := 0; 525 while x < ResBufHigh+1 do 526 case ResBuf[x] of 527 isc_info_db_sql_dialect : 528 begin 529 Inc(x); 530 Len := isc_vax_integer(pchar(@ResBuf[x]), 2); 531 Inc(x, 2); 532 FDatabaseInfo.Dialect := isc_vax_integer(pchar(@ResBuf[x]), Len); 533 Inc(x, Len); 534 end; 535 isc_info_ods_version : 536 begin 537 Inc(x); 538 Len := isc_vax_integer(pchar(@ResBuf[x]), 2); 539 Inc(x, 2); 540 FDatabaseInfo.ODSMajorVersion := isc_vax_integer(pchar(@ResBuf[x]), Len); 541 Inc(x, Len); 542 end; 543 isc_info_version : 544 begin 545 Inc(x); 546 Len := isc_vax_integer(pchar(@ResBuf[x]), 2); 547 Inc(x, 2); 548 SetString(FDatabaseInfo.ServerVersionString, PAnsiChar(@ResBuf[x + 2]), Len-2); 549 FDatabaseInfo.ServerVersion := ParseServerVersion(FDatabaseInfo.ServerVersionString); 550 Inc(x, Len); 551 end; 552 isc_info_end, isc_info_error : Break; 553 isc_info_truncated : Break; //result buffer too small; fix your code! 554 else 555 inc(x); 556 end; 557 end; 558end; 559 560procedure TIBConnection.ResetDatabaseInfo; 561begin 562 FDatabaseInfo.Dialect:=0; 563 FDatabaseInfo.ODSMajorVersion:=0; 564 FDatabaseInfo.ServerVersion:=''; 565 FDatabaseInfo.ServerVersionString:=''; // don't confuse applications with 'Firebird' or 'Interbase' 566end; 567 568 569function TIBConnection.GetODSMajorVersion: integer; 570begin 571 result:=FDatabaseInfo.ODSMajorVersion; 572end; 573 574function TIBConnection.ParseServerVersion(const CompleteVersion: string): string; 575// String representation of integer version number derived from 576// major.minor.build => should give e.g. 020501 577const 578 Delimiter = '.'; 579 DigitsPerNumber = 2; 580 MaxNumbers = 3; 581var 582 BeginPos,EndPos,StartLook,i: integer; 583 NumericPart: string; 584begin 585 result := ''; 586 // Ignore 6.x version number in front of "Firebird" 587 StartLook := Pos('Firebird', CompleteVersion); 588 if StartLook = 0 then 589 StartLook := 1; 590 BeginPos := 0; 591 // Catch all numerics + decimal point: 592 for i := StartLook to Length(CompleteVersion) do 593 begin 594 if (BeginPos > 0) and 595 ((CompleteVersion[i] < '0') or (CompleteVersion[i] > '9')) and (CompleteVersion[i] <> '.') then 596 begin 597 EndPos := i - 1; 598 break; 599 end; 600 if (BeginPos = 0) and 601 (CompleteVersion[i] >= '0') and (CompleteVersion[i] <= '9') then 602 begin 603 BeginPos := i; 604 end; 605 end; 606 if BeginPos > 0 then 607 begin 608 NumericPart := copy(CompleteVersion, BeginPos, 1+EndPos-BeginPos); 609 BeginPos := 1; 610 for i := 1 to MaxNumbers do 611 begin 612 EndPos := PosEx(Delimiter,NumericPart,BeginPos); 613 if EndPos > 0 then 614 begin 615 result := result + rightstr(StringOfChar('0',DigitsPerNumber)+copy(NumericPart,BeginPos,EndPos-BeginPos),DigitsPerNumber); 616 BeginPos := EndPos+1; 617 end 618 else 619 begin 620 result := result + rightstr(StringOfChar('0',DigitsPerNumber)+copy(NumericPart,BeginPos,Length(NumericPart)),DigitsPerNumber); 621 break; 622 end; 623 end; 624 result := leftstr(result + StringOfChar('0',DigitsPerNumber * MaxNumbers), DigitsPerNumber * MaxNumbers); 625 end; 626end; 627 628 629procedure TIBConnection.ConnectFB; 630const 631 isc_dpb_config = 87; 632 CStr_WireCompression = 'WireCompression=true'; 633var 634 ADatabaseName: String; 635 DPB: string; 636 HN : String; 637 638begin 639 DPB := chr(isc_dpb_version1); 640 if (UserName <> '') then 641 begin 642 DPB := DPB + chr(isc_dpb_user_name) + chr(Length(UserName)) + UserName; 643 if (Password <> '') then 644 DPB := DPB + chr(isc_dpb_password) + chr(Length(Password)) + Password; 645 end; 646 if (Role <> '') then 647 DPB := DPB + chr(isc_dpb_sql_role_name) + chr(Length(Role)) + Role; 648 if Length(CharSet) > 0 then 649 DPB := DPB + Chr(isc_dpb_lc_ctype) + Chr(Length(CharSet)) + CharSet; 650 if WireCompression or (SameText(Params.values['WireCompression'],'true')) then 651 DPB := DPB + Chr(isc_dpb_config) + Chr(Length(CStr_WireCompression)) + 652 CStr_WireCompression; 653 654 FDatabaseHandle := nil; 655 HN:=HostName; 656 if HN <> '' then 657 begin 658 if Port<>0 then 659 HN:=HN+'/'+IntToStr(Port); 660 ADatabaseName := HN+':'+DatabaseName 661 end 662 else 663 ADatabaseName := DatabaseName; 664 if isc_attach_database(@FStatus[0], Length(ADatabaseName), @ADatabaseName[1], 665 @FDatabaseHandle, Length(DPB), @DPB[1]) <> 0 then 666 CheckError('DoInternalConnect', FStatus); 667end; 668 669function TIBConnection.GetDialect: integer; 670begin 671 if FDialect = INVALID_DATA then 672 begin 673 if FDatabaseInfo.Dialect=0 then 674 Result := DEFDIALECT 675 else 676 Result := FDatabaseInfo.Dialect; 677 end else 678 Result := FDialect; 679end; 680 681procedure TIBConnection.AllocSQLDA(var aSQLDA : PXSQLDA;Count : integer); 682 683begin 684 FreeSQLDABuffer(aSQLDA); 685 686 if count > -1 then 687 begin 688 reAllocMem(aSQLDA, XSQLDA_Length(Count)); 689 { Zero out the memory block to avoid problems with exceptions within the 690 constructor of this class. } 691 FillChar(aSQLDA^, XSQLDA_Length(Count), 0); 692 693 aSQLDA^.Version := sqlda_version1; 694 aSQLDA^.SQLN := Count; 695 end 696 else 697 reAllocMem(aSQLDA,0); 698end; 699 700procedure TIBConnection.TranslateFldType(SQLType, SQLSubType, SQLLen, SQLScale : integer; 701 out TrType : TFieldType; out TrLen, TrPrec : word); 702begin 703 TrLen := 0; 704 TrPrec := 0; 705 if SQLScale < 0 then 706 begin 707 TrLen := abs(SQLScale); 708 if (TrLen <= MaxBCDScale) then //Note: NUMERIC(18,3) or (17,2) must be mapped to ftFmtBCD, but we do not know Precision 709 TrType := ftBCD 710 else 711 TrType := ftFMTBcd; 712 case (SQLType and not 1) of 713 SQL_SHORT : TrPrec := 4; 714 SQL_LONG : TrPrec := 9; 715 SQL_DOUBLE, 716 SQL_INT64 : TrPrec := 18; 717 else TrPrec := SQLLen; 718 end; 719 end 720 else case (SQLType and not 1) of 721 SQL_VARYING : 722 begin 723 TrType := ftString; 724 TrLen := SQLLen; 725 end; 726 SQL_TEXT : 727 begin 728 TrType := ftFixedChar; 729 TrLen := SQLLen; 730 end; 731 SQL_TYPE_DATE : 732 TrType := ftDate; 733 SQL_TYPE_TIME : 734 TrType := ftTime; 735 SQL_TIMESTAMP : 736 TrType := ftDateTime; 737 SQL_ARRAY : 738 begin 739 TrType := ftArray; 740 TrLen := SQLLen; 741 end; 742 SQL_BLOB : 743 begin 744 if SQLSubType = isc_blob_text then 745 TrType := ftMemo 746 else 747 TrType := ftBlob; 748 TrLen := SQLLen; 749 end; 750 SQL_SHORT : 751 TrType := ftSmallint; 752 SQL_LONG : 753 TrType := ftInteger; 754 SQL_INT64 : 755 TrType := ftLargeInt; 756 SQL_DOUBLE : 757 TrType := ftFloat; 758 SQL_FLOAT : 759 TrType := ftFloat; 760 SQL_BOOLEAN_INTERBASE, SQL_BOOLEAN_FIREBIRD : 761 TrType := ftBoolean; 762 else 763 TrType := ftUnknown; 764 end; 765end; 766 767function TIBConnection.AllocateCursorHandle: TSQLCursor; 768 769var curs : TIBCursor; 770 771begin 772 curs := TIBCursor.create; 773 curs.sqlda := nil; 774 curs.StatementHandle := nil; 775 curs.FPrepared := False; 776 AllocSQLDA(curs.SQLDA,0); 777 result := curs; 778end; 779 780procedure TIBConnection.DeAllocateCursorHandle(var cursor : TSQLCursor); 781 782begin 783 if assigned(cursor) then with cursor as TIBCursor do 784 begin 785 AllocSQLDA(SQLDA,-1); 786 AllocSQLDA(in_SQLDA,-1); 787 end; 788 FreeAndNil(cursor); 789end; 790 791function TIBConnection.AllocateTransactionHandle: TSQLHandle; 792 793begin 794 result := TIBTrans.create; 795end; 796 797procedure TIBConnection.PrepareStatement(cursor: TSQLCursor;ATransaction : TSQLTransaction;buf : string; AParams : TParams); 798 799var DatabaseHandle : pointer; 800 x : Smallint; 801 info_request : string; 802 resbuf : array[0..7] of byte; 803 blockSize : integer; 804 IBStatementType: integer; 805 806begin 807 with cursor as TIBcursor do 808 begin 809 DatabaseHandle := GetHandle; 810 TransactionHandle := aTransaction.Handle; 811 812 if isc_dsql_allocate_statement(@Status[0], @DatabaseHandle, @StatementHandle) <> 0 then 813 CheckError('PrepareStatement', Status); 814 815 if assigned(AParams) and (AParams.count > 0) then 816 begin 817 buf := AParams.ParseSQL(buf,false,sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions,psInterbase,paramBinding); 818 if LogEvent(detActualSQL) then 819 Log(detActualSQL,Buf); 820 end; 821 822 if isc_dsql_prepare(@Status[0], @TransactionHandle, @StatementHandle, 0, @Buf[1], Dialect, nil) <> 0 then 823 CheckError('PrepareStatement', Status); 824 825 if assigned(AParams) and (AParams.count > 0) then 826 begin 827 AllocSQLDA(in_SQLDA,Length(ParamBinding)); 828 if isc_dsql_describe_bind(@Status[0], @StatementHandle, 1, in_SQLDA) <> 0 then 829 CheckError('PrepareStatement', Status); 830 if in_SQLDA^.SQLD > in_SQLDA^.SQLN then 831 DatabaseError(SParameterCountIncorrect,self); 832 {$push} 833 {$R-} 834 for x := 0 to in_SQLDA^.SQLD - 1 do with in_SQLDA^.SQLVar[x] do 835 begin 836 if ((SQLType and not 1) = SQL_VARYING) then 837 SQLData := AllocMem(in_SQLDA^.SQLVar[x].SQLLen+2) 838 else if SQLType <> SQL_NULL then 839 SQLData := AllocMem(in_SQLDA^.SQLVar[x].SQLLen); 840 // Always force the creation of slqind for parameters. It could be 841 // that a database trigger takes care of inserting null values, so 842 // it should always be possible to pass null parameters. If that fails, 843 // the database server will generate the appropriate error. 844 sqltype := sqltype or 1; 845 new(sqlind); 846 end; 847 {$pop} 848 end 849 else 850 AllocSQLDA(in_SQLDA,0); 851 852 // Get the statement type from firebird/interbase 853 info_request := chr(isc_info_sql_stmt_type); 854 if isc_dsql_sql_info(@Status[0],@StatementHandle,Length(info_request), @info_request[1],sizeof(resbuf),@resbuf) <> 0 then 855 CheckError('PrepareStatement', Status); 856 assert(resbuf[0]=isc_info_sql_stmt_type); 857 BlockSize:=isc_vax_integer(@resbuf[1],2); 858 IBStatementType:=isc_vax_integer(@resbuf[3],blockSize); 859 assert(resbuf[3+blockSize]=isc_info_end); 860 // If the StatementType is isc_info_sql_stmt_exec_procedure then 861 // override the statement type derived by parsing the query. 862 // This to recognize statements like 'insert into .. returning' correctly 863 case IBStatementType of 864 isc_info_sql_stmt_select: FStatementType := stSelect; 865 isc_info_sql_stmt_insert: FStatementType := stInsert; 866 isc_info_sql_stmt_update: FStatementType := stUpdate; 867 isc_info_sql_stmt_delete: FStatementType := stDelete; 868 isc_info_sql_stmt_exec_procedure: FStatementType := stExecProcedure; 869 end; 870 FSelectable := FStatementType in [stSelect,stExecProcedure]; 871 872 if FSelectable then 873 begin 874 if isc_dsql_describe(@Status[0], @StatementHandle, 1, SQLDA) <> 0 then 875 CheckError('PrepareSelect', Status); 876 if SQLDA^.SQLD > SQLDA^.SQLN then 877 begin 878 AllocSQLDA(SQLDA,SQLDA^.SQLD); 879 if isc_dsql_describe(@Status[0], @StatementHandle, 1, SQLDA) <> 0 then 880 CheckError('PrepareSelect', Status); 881 end; 882 FSelectable := SQLDA^.SQLD > 0; 883 {$push} 884 {$R-} 885 for x := 0 to SQLDA^.SQLD - 1 do with SQLDA^.SQLVar[x] do 886 begin 887 if ((SQLType and not 1) = SQL_VARYING) then 888 SQLData := AllocMem(SQLDA^.SQLVar[x].SQLLen+2) 889 else 890 SQLData := AllocMem(SQLDA^.SQLVar[x].SQLLen); 891 if (SQLType and 1) = 1 then New(SQLInd); 892 end; 893 {$pop} 894 end; 895 FPrepared := True; 896 end; 897end; 898 899procedure TIBConnection.UnPrepareStatement(cursor : TSQLCursor); 900 901begin 902 with cursor as TIBcursor do 903 if assigned(StatementHandle) Then 904 begin 905 if isc_dsql_free_statement(@Status[0], @StatementHandle, DSQL_Drop) <> 0 then 906 CheckError('FreeStatement', Status); 907 StatementHandle := nil; 908 FPrepared := False; 909 end; 910end; 911 912procedure TIBConnection.FreeSQLDABuffer(var aSQLDA : PXSQLDA); 913 914var x : Smallint; 915 916begin 917{$push} 918{$R-} 919 if assigned(aSQLDA) then 920 for x := 0 to aSQLDA^.SQLN - 1 do 921 begin 922 reAllocMem(aSQLDA^.SQLVar[x].SQLData,0); 923 if assigned(aSQLDA^.SQLVar[x].sqlind) then 924 begin 925 Dispose(aSQLDA^.SQLVar[x].sqlind); 926 aSQLDA^.SQLVar[x].sqlind := nil; 927 end 928 end; 929{$pop} 930end; 931 932function TIBConnection.IsDialectStored: boolean; 933begin 934 result := (FDialect<>INVALID_DATA); 935end; 936 937procedure TIBConnection.DoConnect; 938const NoQuotes: TQuoteChars = (' ',' '); 939begin 940 inherited DoConnect; 941 GetDatabaseInfo; //Get db dialect, db metadata 942 if Dialect < 3 then 943 FieldNameQuoteChars := NoQuotes 944 else 945 FieldNameQuoteChars := DoubleQuotes; 946end; 947 948procedure TIBConnection.FreeFldBuffers(cursor : TSQLCursor); 949 950begin 951 with cursor as TIBCursor do 952 begin 953 FreeSQLDABuffer(SQLDA); 954 FreeSQLDABuffer(in_SQLDA); 955 SetLength(FieldBinding,0); 956 end; 957end; 958 959procedure TIBConnection.Execute(cursor: TSQLCursor;atransaction:tSQLtransaction; AParams : TParams); 960var TransactionHandle : pointer; 961 out_SQLDA : PXSQLDA; 962begin 963 TransactionHandle := aTransaction.Handle; 964 if Assigned(APArams) and (AParams.count > 0) then SetParameters(cursor, atransaction, AParams); 965 if LogEvent(detParamValue) then 966 LogParams(AParams); 967 with cursor as TIBCursor do 968 begin 969 if FStatementType = stExecProcedure then 970 out_SQLDA := SQLDA 971 else 972 out_SQLDA := nil; 973 if isc_dsql_execute2(@Status[0], @TransactionHandle, @StatementHandle, 1, in_SQLDA, out_SQLDA) <> 0 then 974 CheckError('Execute', Status); 975 end; 976end; 977 978 979procedure TIBConnection.AddFieldDefs(cursor: TSQLCursor;FieldDefs : TFieldDefs); 980const 981 CS_NONE=0; 982 CS_BINARY=1; 983var 984 i : integer; 985 PSQLVar : PXSQLVAR; 986 TransLen, 987 TransPrec : word; 988 TransType : TFieldType; 989 990 function GetBlobCharset(TableName,ColumnName: Pointer): smallint; 991 var TransactionHandle: pointer; 992 BlobDesc: TISC_BLOB_DESC; 993 Global: array[0..31] of AnsiChar; 994 begin 995 TransactionHandle := TIBCursor(cursor).TransactionHandle; 996 if isc_blob_lookup_desc(@FStatus[0], @FDatabaseHandle, @TransactionHandle, 997 TableName, ColumnName, @BlobDesc, @Global) <> 0 then 998 CheckError('Blob Charset', FStatus); 999 Result := BlobDesc.blob_desc_charset; 1000 end; 1001 1002begin 1003 {$push} 1004 {$R-} 1005 with cursor as TIBCursor do 1006 begin 1007 setlength(FieldBinding,SQLDA^.SQLD); 1008 for i := 0 to SQLDA^.SQLD - 1 do 1009 begin 1010 PSQLVar := @SQLDA^.SQLVar[i]; 1011 TranslateFldType(PSQLVar^.SQLType, PSQLVar^.sqlsubtype, PSQLVar^.SQLLen, PSQLVar^.SQLScale, 1012 TransType, TransLen, TransPrec); 1013 1014 // [var]char or blob column character set NONE or OCTETS overrides connection charset 1015 if (((TransType in [ftString, ftFixedChar]) and (PSQLVar^.sqlsubtype and $FF in [CS_NONE,CS_BINARY])) and not UseConnectionCharSetIfNone) 1016 or 1017 ((TransType = ftMemo) and (PSQLVar^.relname_length>0) and (PSQLVar^.sqlname_length>0) and (GetBlobCharset(@PSQLVar^.relname,@PSQLVar^.sqlname) in [CS_NONE,CS_BINARY])) then 1018 FieldDefs.Add(PSQLVar^.AliasName, TransType, TransLen, TransPrec, (PSQLVar^.sqltype and 1)=0, False, i+1, CP_NONE) 1019 else 1020 AddFieldDef(FieldDefs, i+1, PSQLVar^.AliasName, TransType, TransLen, TransPrec, True, (PSQLVar^.sqltype and 1)=0, False); 1021 1022 FieldBinding[i] := i; 1023 end; 1024 end; 1025 {$pop} 1026end; 1027 1028function TIBConnection.GetHandle: pointer; 1029begin 1030 Result := FDatabaseHandle; 1031end; 1032 1033function TIBConnection.Fetch(cursor : TSQLCursor) : boolean; 1034var 1035 retcode : integer; 1036begin 1037 with cursor as TIBCursor do 1038 begin 1039 if FStatementType = stExecProcedure then 1040 //do not fetch from a non-select statement, i.e. statement which has no cursor 1041 //on Firebird 2.5+ it leads to error 'Invalid cursor reference' 1042 if SQLDA^.SQLD = 0 then 1043 retcode := 100 //no more rows to retrieve 1044 else 1045 begin 1046 retcode := 0; 1047 SQLDA^.SQLD := 0; //hack: mark after first fetch 1048 end 1049 else 1050 retcode := isc_dsql_fetch(@Status[0], @StatementHandle, 1, SQLDA); 1051 if (retcode <> 0) and (retcode <> 100) then 1052 CheckError('Fetch', Status); 1053 end; 1054 Result := (retcode = 0); 1055end; 1056 1057function IntPower10(e: integer): double; 1058const PreComputedPower10: array[0..9] of integer = (1,10,100,1000,10000,100000,1000000,10000000,100000000,1000000000); 1059var n: integer; 1060begin 1061 n := abs(e); //exponent can't be greater than 18 1062 if n <= 9 then 1063 Result := PreComputedPower10[n] 1064 else 1065 Result := PreComputedPower10[9] * PreComputedPower10[n-9]; 1066 if e < 0 then 1067 Result := 1 / Result; 1068end; 1069 1070procedure TIBConnection.SetParameters(cursor : TSQLCursor; aTransation : TSQLTransaction; AParams : TParams); 1071 1072var 1073 // This should be a pointer, because the ORIGINAL variables must be modified. 1074 VSQLVar : PXSQLVAR; 1075 AParam : TParam; 1076 s : rawbytestring; 1077 i : integer; 1078 1079 procedure SetBlobParam; 1080 var 1081 TransactionHandle : pointer; 1082 BlobId : ISC_QUAD; 1083 BlobHandle : Isc_blob_Handle; 1084 BlobSize, 1085 BlobBytesWritten : longint; 1086 begin 1087 {$push} 1088 {$R-} 1089 with cursor as TIBCursor do 1090 begin 1091 TransactionHandle := aTransation.Handle; 1092 BlobHandle := FB_API_NULLHANDLE; 1093 if isc_create_blob(@FStatus[0], @FDatabaseHandle, @TransactionHandle, @BlobHandle, @BlobId) <> 0 then 1094 CheckError('TIBConnection.CreateBlobStream', FStatus); 1095 1096 if VSQLVar^.sqlsubtype = isc_blob_text then 1097 s := GetAsString(AParam) 1098 else 1099 s := AParam.AsString; // to avoid unwanted conversions keep it synchronized with TBlobField.GetAsVariant 1100 // best would be use AsBytes, but for now let it as is 1101 BlobSize := Length(s); 1102 1103 BlobBytesWritten := 0; 1104 i := 0; 1105 1106 // Write in segments of MAXBLOBSEGMENTSIZE, as that is the fastest. 1107 // We ignore BlobSegmentSize property. 1108 while BlobBytesWritten < (BlobSize-MAXBLOBSEGMENTSIZE) do 1109 begin 1110 isc_put_segment(@FStatus[0], @BlobHandle, MAXBLOBSEGMENTSIZE, @s[(i*MAXBLOBSEGMENTSIZE)+1]); 1111 inc(BlobBytesWritten,MAXBLOBSEGMENTSIZE); 1112 inc(i); 1113 end; 1114 if BlobBytesWritten <> BlobSize then 1115 isc_put_segment(@FStatus[0], @BlobHandle, BlobSize-BlobBytesWritten, @s[(i*MAXBLOBSEGMENTSIZE)+1]); 1116 1117 if isc_close_blob(@FStatus[0], @BlobHandle) <> 0 then 1118 CheckError('TIBConnection.CreateBlobStream isc_close_blob', FStatus); 1119 1120 Move(BlobId, VSQLVar^.SQLData^, VSQLVar^.SQLLen); 1121 end; 1122 {$pop} 1123 end; 1124 1125var 1126 SQLVarNr : integer; 1127 si : smallint; 1128 li : LargeInt; 1129 CurrBuff : pchar; 1130 w : word; 1131 1132begin 1133 {$push} 1134 {$R-} 1135 with cursor as TIBCursor do for SQLVarNr := 0 to High(ParamBinding){AParams.count-1} do 1136 begin 1137 AParam := AParams[ParamBinding[SQLVarNr]]; 1138 VSQLVar := @in_sqlda^.SQLvar[SQLVarNr]; 1139 if AParam.IsNull then 1140 VSQLVar^.SQLInd^ := -1 1141 else 1142 begin 1143 VSQLVar^.SQLInd^ := 0; 1144 1145 case (VSQLVar^.sqltype and not 1) of 1146 SQL_SHORT, SQL_BOOLEAN_INTERBASE : 1147 begin 1148 if VSQLVar^.sqlscale = 0 then 1149 si := AParam.AsSmallint 1150 else 1151 si := Round(AParam.AsCurrency * IntPower10(-VSQLVar^.sqlscale)); 1152 i := si; 1153 Move(i, VSQLVar^.SQLData^, VSQLVar^.SQLLen); 1154 end; 1155 SQL_LONG : 1156 begin 1157 if VSQLVar^.sqlscale = 0 then 1158 i := AParam.AsInteger 1159 else 1160 i := Round(AParam.AsFloat * IntPower10(-VSQLVar^.sqlscale)); //*any number of digits 1161 Move(i, VSQLVar^.SQLData^, VSQLVar^.SQLLen); 1162 end; 1163 SQL_INT64: 1164 begin 1165 if VSQLVar^.sqlscale = 0 then 1166 li := AParam.AsLargeInt 1167 else if AParam.DataType = ftFMTBcd then 1168 li := AParam.AsFMTBCD * IntPower10(-VSQLVar^.sqlscale) 1169 else 1170 li := Round(AParam.AsCurrency * IntPower10(-VSQLVar^.sqlscale)); 1171 Move(li, VSQLVar^.SQLData^, VSQLVar^.SQLLen); 1172 end; 1173 SQL_DOUBLE, SQL_FLOAT: 1174 SetFloat(VSQLVar^.SQLData, AParam.AsFloat, VSQLVar^.SQLLen); 1175 SQL_BLOB : 1176 SetBlobParam; 1177 SQL_VARYING, SQL_TEXT : 1178 begin 1179 Case AParam.DataType of 1180 ftDate : 1181 s := FormatDateTime('yyyy-mm-dd', AParam.AsDateTime); 1182 ftTime : 1183 s := FormatDateTime('hh":"nn":"ss', AParam.AsDateTime); 1184 ftDateTime, 1185 ftTimeStamp : 1186 s := FormatDateTime('yyyy-mm-dd hh":"nn":"ss', AParam.AsDateTime); 1187 else 1188 s := GetAsString(AParam); 1189 end; 1190 w := length(s); // a word is enough, since the max-length of a string in interbase is 32k 1191 if ((VSQLVar^.SQLType and not 1) = SQL_VARYING) then 1192 begin 1193 VSQLVar^.SQLLen := w; 1194 ReAllocMem(VSQLVar^.SQLData, VSQLVar^.SQLLen+2); 1195 CurrBuff := VSQLVar^.SQLData; 1196 move(w,CurrBuff^,sizeof(w)); 1197 inc(CurrBuff,sizeof(w)); 1198 end 1199 else 1200 begin 1201 // The buffer-length is always VSQLVar^.sqllen, nothing more, nothing less 1202 // so fill the complete buffer with valid data. Adding #0 will lead 1203 // to problems, because the #0 will be seen as a part of the (binary) string 1204 CurrBuff := VSQLVar^.SQLData; 1205 w := VSQLVar^.sqllen; 1206 s := PadRight(s,w); 1207 end; 1208 Move(s[1], CurrBuff^, w); 1209 end; 1210 SQL_TYPE_DATE, SQL_TYPE_TIME, SQL_TIMESTAMP : 1211 SetDateTime(VSQLVar^.SQLData, AParam.AsDateTime, VSQLVar^.SQLType); 1212 SQL_BOOLEAN_FIREBIRD: 1213 PByte(VSQLVar^.SQLData)^ := Byte(AParam.AsBoolean); 1214 else 1215 if (VSQLVar^.sqltype <> SQL_NULL) then 1216 DatabaseErrorFmt(SUnsupportedParameter,[FieldTypeNames[AParam.DataType]],self); 1217 end {case} 1218 end; 1219 end; 1220 {$pop} 1221end; 1222 1223function TIBConnection.LoadField(cursor : TSQLCursor; FieldDef : TFieldDef; buffer : pointer; out CreateBlob : boolean) : boolean; 1224 1225var 1226 VSQLVar : PXSQLVAR; 1227 VarcharLen : word; 1228 CurrBuff : pchar; 1229 c : currency; 1230 AFmtBcd : tBCD; 1231 1232 function BcdDivPower10(Dividend: largeint; e: integer): TBCD; 1233 var d: double; 1234 begin 1235 d := Dividend / IntPower10(e); 1236 Result := StrToBCD( FloatToStr(d) ); 1237 end; 1238 1239begin 1240 CreateBlob := False; 1241 with cursor as TIBCursor do 1242 begin 1243 {$push} 1244 {$R-} 1245 VSQLVar := @SQLDA^.SQLVar[ FieldBinding[FieldDef.FieldNo-1] ]; 1246 1247 // Joost, 5 jan 2006: I disabled the following, since it's useful for 1248 // debugging, but it also slows things down. In principle things can only go 1249 // wrong when FieldDefs is changed while the dataset is opened. A user just 1250 // shoudn't do that. ;) (The same is done in PQConnection) 1251 1252 // if VSQLVar^.AliasName <> FieldDef.Name then 1253 // DatabaseErrorFmt(SFieldNotFound,[FieldDef.Name],self); 1254 if assigned(VSQLVar^.SQLInd) and (VSQLVar^.SQLInd^ = -1) then 1255 result := false 1256 else 1257 begin 1258 1259 with VSQLVar^ do 1260 if ((SQLType and not 1) = SQL_VARYING) then 1261 begin 1262 Move(SQLData^, VarcharLen, 2); 1263 CurrBuff := SQLData + 2; 1264 end 1265 else 1266 begin 1267 CurrBuff := SQLData; 1268 VarCharLen := FieldDef.Size; 1269 end; 1270 1271 Result := true; 1272 case FieldDef.DataType of 1273 ftBCD : 1274 begin 1275 case VSQLVar^.SQLLen of 1276 2 : c := PSmallint(CurrBuff)^ / IntPower10(-VSQLVar^.SQLScale); 1277 4 : c := PLongint(CurrBuff)^ / IntPower10(-VSQLVar^.SQLScale); 1278 8 : if Dialect < 3 then 1279 c := PDouble(CurrBuff)^ 1280 else 1281 c := PLargeint(CurrBuff)^ / IntPower10(-VSQLVar^.SQLScale); 1282 else 1283 Result := False; // Just to be sure, in principle this will never happen 1284 end; {case} 1285 Move(c, buffer^ , sizeof(c)); 1286 end; 1287 ftFMTBcd : 1288 begin 1289 case VSQLVar^.SQLLen of 1290 2 : AFmtBcd := BcdDivPower10(PSmallint(CurrBuff)^, -VSQLVar^.SQLScale); 1291 4 : AFmtBcd := BcdDivPower10(PLongint(CurrBuff)^, -VSQLVar^.SQLScale); 1292 8 : if Dialect < 3 then 1293 AFmtBcd := PDouble(CurrBuff)^ 1294 else 1295 AFmtBcd := BcdDivPower10(PLargeint(CurrBuff)^, -VSQLVar^.SQLScale); 1296 else 1297 Result := False; // Just to be sure, in principle this will never happen 1298 end; {case} 1299 Move(AFmtBcd, buffer^ , sizeof(AFmtBcd)); 1300 end; 1301 ftInteger : 1302 begin 1303 FillByte(buffer^,sizeof(Longint),0); 1304 Move(CurrBuff^, Buffer^, VSQLVar^.SQLLen); 1305 end; 1306 ftLargeint : 1307 begin 1308 FillByte(buffer^,sizeof(LargeInt),0); 1309 Move(CurrBuff^, Buffer^, VSQLVar^.SQLLen); 1310 end; 1311 ftSmallint : 1312 begin 1313 FillByte(buffer^,sizeof(Smallint),0); 1314 Move(CurrBuff^, Buffer^, VSQLVar^.SQLLen); 1315 end; 1316 ftDate, ftTime, ftDateTime: 1317 GetDateTime(CurrBuff, Buffer, VSQLVar^.SQLType); 1318 ftString, ftFixedChar : 1319 begin 1320 Move(CurrBuff^, Buffer^, VarCharLen); 1321 PChar(Buffer + VarCharLen)^ := #0; 1322 end; 1323 ftFloat : 1324 GetFloat(CurrBuff, Buffer, VSQLVar^.SQLLen); 1325 ftBlob, 1326 ftMemo : 1327 begin // load the BlobIb in field's buffer 1328 FillByte(buffer^,sizeof(TBufBlobField),0); 1329 Move(CurrBuff^, Buffer^, VSQLVar^.SQLLen); 1330 end; 1331 ftBoolean : 1332 begin 1333 case VSQLVar^.SQLLen of 1334 1: PWordBool(Buffer)^ := PByte(CurrBuff)^ <> 0; // Firebird 1335 2: PWordBool(Buffer)^ := PSmallint(CurrBuff)^ <> 0; // Interbase 1336 end; 1337 end 1338 else 1339 begin 1340 result := false; 1341 databaseerrorfmt(SUnsupportedFieldType, [Fieldtypenames[FieldDef.DataType], Self]); 1342 end 1343 end; { case } 1344 end; { if/else } 1345 {$pop} 1346 end; { with cursor } 1347end; 1348 1349{$DEFINE SUPPORT_MSECS} 1350{$IFDEF SUPPORT_MSECS} 1351 const 1352 IBDateOffset = 15018; //an offset from 17 Nov 1858. 1353 IBTimeFractionsPerDay = SecsPerDay * ISC_TIME_SECONDS_PRECISION; //Number of Firebird time fractions per day 1354{$ELSE} 1355 {$PACKRECORDS C} 1356 type 1357 TTm = record 1358 tm_sec : longint; 1359 tm_min : longint; 1360 tm_hour : longint; 1361 tm_mday : longint; 1362 tm_mon : longint; 1363 tm_year : longint; 1364 tm_wday : longint; 1365 tm_yday : longint; 1366 tm_isdst: longint; 1367 __tm_gmtoff : PtrInt; // Seconds east of UTC 1368 __tm_zone : PAnsiChar; // Timezone abbreviation 1369 end; 1370 {$PACKRECORDS DEFAULT} 1371{$ENDIF} 1372 1373procedure TIBConnection.GetDateTime(CurrBuff, Buffer : pointer; AType : integer); 1374var 1375 {$IFNDEF SUPPORT_MSECS} 1376 CTime : TTm; // C struct time 1377 STime : TSystemTime; // System time 1378 {$ENDIF} 1379 PTime : TDateTime; // Pascal time 1380begin 1381 case (AType and not 1) of 1382 SQL_TYPE_DATE : 1383 {$IFNDEF SUPPORT_MSECS} 1384 isc_decode_sql_date(PISC_DATE(CurrBuff), @CTime); 1385 {$ELSE} 1386 PTime := PISC_DATE(CurrBuff)^ - IBDateOffset; 1387 {$ENDIF} 1388 SQL_TYPE_TIME : 1389 {$IFNDEF SUPPORT_MSECS} 1390 isc_decode_sql_time(PISC_TIME(CurrBuff), @CTime); 1391 {$ELSE} 1392 PTime := PISC_TIME(CurrBuff)^ / IBTimeFractionsPerDay; 1393 {$ENDIF} 1394 SQL_TIMESTAMP : 1395 begin 1396 {$IFNDEF SUPPORT_MSECS} 1397 isc_decode_timestamp(PISC_TIMESTAMP(CurrBuff), @CTime); 1398 {$ELSE} 1399 PTime := ComposeDateTime( 1400 PISC_TIMESTAMP(CurrBuff)^.timestamp_date - IBDateOffset, 1401 PISC_TIMESTAMP(CurrBuff)^.timestamp_time / IBTimeFractionsPerDay 1402 ); 1403 {$ENDIF} 1404 end 1405 else 1406 Raise EIBDatabaseError.CreateFmt('Invalid parameter type for date Decode : %d',[(AType and not 1)]); 1407 end; 1408 1409 {$IFNDEF SUPPORT_MSECS} 1410 STime.Year := CTime.tm_year + 1900; 1411 STime.Month := CTime.tm_mon + 1; 1412 STime.Day := CTime.tm_mday; 1413 STime.Hour := CTime.tm_hour; 1414 STime.Minute := CTime.tm_min; 1415 STime.Second := CTime.tm_sec; 1416 STime.Millisecond := 0; 1417 1418 PTime := SystemTimeToDateTime(STime); 1419 {$ENDIF} 1420 Move(PTime, Buffer^, SizeOf(PTime)); 1421end; 1422 1423procedure TIBConnection.SetDateTime(CurrBuff: pointer; PTime : TDateTime; AType : integer); 1424{$IFNDEF SUPPORT_MSECS} 1425var 1426 CTime : TTm; // C struct time 1427 STime : TSystemTime; // System time 1428{$ENDIF} 1429begin 1430 {$IFNDEF SUPPORT_MSECS} 1431 DateTimeToSystemTime(PTime,STime); 1432 1433 CTime.tm_year := STime.Year - 1900; 1434 CTime.tm_mon := STime.Month -1; 1435 CTime.tm_mday := STime.Day; 1436 CTime.tm_hour := STime.Hour; 1437 CTime.tm_min := STime.Minute; 1438 CTime.tm_sec := STime.Second; 1439 {$ENDIF} 1440 case (AType and not 1) of 1441 SQL_TYPE_DATE : 1442 {$IFNDEF SUPPORT_MSECS} 1443 isc_encode_sql_date(@CTime, PISC_DATE(CurrBuff)); 1444 {$ELSE} 1445 PISC_DATE(CurrBuff)^ := Trunc(PTime) + IBDateOffset; 1446 {$ENDIF} 1447 SQL_TYPE_TIME : 1448 {$IFNDEF SUPPORT_MSECS} 1449 isc_encode_sql_time(@CTime, PISC_TIME(CurrBuff)); 1450 {$ELSE} 1451 PISC_TIME(CurrBuff)^ := Round(abs(Frac(PTime)) * IBTimeFractionsPerDay); 1452 {$ENDIF} 1453 SQL_TIMESTAMP : 1454 begin 1455 {$IFNDEF SUPPORT_MSECS} 1456 isc_encode_timestamp(@CTime, PISC_TIMESTAMP(CurrBuff)); 1457 {$ELSE} 1458 PISC_TIMESTAMP(CurrBuff)^.timestamp_date := Trunc(PTime) + IBDateOffset; 1459 PISC_TIMESTAMP(CurrBuff)^.timestamp_time := Round(abs(Frac(PTime)) * IBTimeFractionsPerDay); 1460 if PISC_TIMESTAMP(CurrBuff)^.timestamp_time = IBTimeFractionsPerDay then 1461 begin 1462 // If PTime is for example 0.99999999999999667, the time-portion of the 1463 // TDateTime is rounded into a whole day. Firebird does not accept that. 1464 inc(PISC_TIMESTAMP(CurrBuff)^.timestamp_date); 1465 PISC_TIMESTAMP(CurrBuff)^.timestamp_time := 0; 1466 end; 1467 {$ENDIF} 1468 end 1469 else 1470 Raise EIBDatabaseError.CreateFmt('Invalid parameter type for date encode : %d',[(AType and not 1)]); 1471 end; 1472end; 1473 1474function TIBConnection.GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; 1475 1476var s : string; 1477 1478begin 1479 case SchemaType of 1480 stTables : s := 'select '+ 1481 'rdb$relation_id as recno, '+ 1482 '''' + DatabaseName + ''' as catalog_name, '+ 1483 ''''' as schema_name, '+ 1484 'rdb$relation_name as table_name, '+ 1485 '0 as table_type '+ 1486 'from '+ 1487 'rdb$relations '+ 1488 'where '+ 1489 '(rdb$system_flag = 0 or rdb$system_flag is null) ' + // and rdb$view_blr is null 1490 'order by rdb$relation_name'; 1491 1492 stSysTables : s := 'select '+ 1493 'rdb$relation_id as recno, '+ 1494 '''' + DatabaseName + ''' as catalog_name, '+ 1495 ''''' as schema_name, '+ 1496 'rdb$relation_name as table_name, '+ 1497 '0 as table_type '+ 1498 'from '+ 1499 'rdb$relations '+ 1500 'where '+ 1501 '(rdb$system_flag > 0) ' + // and rdb$view_blr is null 1502 'order by rdb$relation_name'; 1503 1504 stProcedures : s := 'select '+ 1505 'rdb$procedure_id as recno, '+ 1506 '''' + DatabaseName + ''' as catalog_name, '+ 1507 ''''' as schema_name, '+ 1508 'rdb$procedure_name as procedure_name, '+ 1509 '0 as procedure_type, '+ 1510 'rdb$procedure_inputs as in_params, '+ 1511 'rdb$procedure_outputs as out_params '+ 1512 'from '+ 1513 'rdb$procedures '+ 1514 'WHERE '+ 1515 '(rdb$system_flag = 0 or rdb$system_flag is null)'; 1516 1517 stColumns : s := 'SELECT '+ 1518 'rdb$field_id as recno, '+ 1519 '''' + DatabaseName + ''' as catalog_name, '+ 1520 ''''' as schema_name, '+ 1521 'rdb$relation_name as table_name, '+ 1522 'r.rdb$field_name as column_name, '+ 1523 'rdb$field_position+1 as column_position, '+ 1524 '0 as column_type, '+ 1525 'rdb$field_type as column_datatype, '+ 1526 'rdb$type_name as column_typename, '+ 1527 'rdb$field_sub_type as column_subtype, '+ 1528 'rdb$field_precision as column_precision, '+ 1529 '-rdb$field_scale as column_scale, '+ 1530 'rdb$field_length as column_length, '+ 1531 'case r.rdb$null_flag when 1 then 0 else 1 end as column_nullable '+ 1532 'FROM '+ 1533 'rdb$relation_fields r '+ 1534 'JOIN rdb$fields f ON r.rdb$field_source=f.rdb$field_name '+ 1535 'JOIN rdb$types t ON f.rdb$field_type=t.rdb$type AND t.rdb$field_name=''RDB$FIELD_TYPE'' '+ 1536 'WHERE '+ 1537 '(r.rdb$system_flag = 0 or r.rdb$system_flag is null) and (rdb$relation_name = ''' + Uppercase(SchemaObjectName) + ''') ' + 1538 'ORDER BY '+ 1539 'r.rdb$field_name'; 1540 stSequences : s := 'SELECT ' + 1541 'rdb$generator_id as recno,' + 1542 '''' + DatabaseName + ''' as sequence_catalog,' + 1543 ''''' as sequence_schema,' + 1544 'rdb$generator_name as sequence_name ' + 1545 'FROM ' + 1546 'rdb$generators ' + 1547 'WHERE ' + 1548 'rdb$system_flag = 0 or rdb$system_flag is null ' + 1549 'ORDER BY ' + 1550 'rdb$generator_name'; 1551 else 1552 DatabaseError(SMetadataUnavailable) 1553 end; {case} 1554 result := s; 1555end; 1556 1557function TIBConnection.GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string; 1558begin 1559 Result := Format('SELECT gen_id(%s, %d) FROM RDB$DATABASE', [SequenceName, IncrementBy]); 1560end; 1561 1562procedure TIBConnection.UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); 1563 1564var qry : TSQLQuery; 1565 1566begin 1567 if not assigned(Transaction) then 1568 DatabaseError(SErrConnTransactionnSet); 1569 1570 if (length(TableName)>2) and (TableName[1]='"') and (TableName[length(TableName)]='"') then 1571 TableName := AnsiDequotedStr(TableName, '"') 1572 else 1573 TableName := UpperCase(TableName); 1574 1575 qry := tsqlquery.Create(nil); 1576 qry.transaction := Transaction; 1577 qry.database := Self; 1578 with qry do 1579 begin 1580 ReadOnly := True; 1581 sql.clear; 1582 sql.add('select '+ 1583 'ind.rdb$index_name, '+ 1584 'ind.rdb$relation_name, '+ 1585 'ind.rdb$unique_flag, '+ 1586 'ind_seg.rdb$field_name, '+ 1587 'rel_con.rdb$constraint_type, '+ 1588 'ind.rdb$index_type '+ 1589 'from '+ 1590 'rdb$index_segments ind_seg, '+ 1591 'rdb$indices ind '+ 1592 'left outer join '+ 1593 'rdb$relation_constraints rel_con '+ 1594 'on '+ 1595 'rel_con.rdb$index_name = ind.rdb$index_name '+ 1596 'where '+ 1597 '(ind_seg.rdb$index_name = ind.rdb$index_name) and '+ 1598 '(ind.rdb$relation_name=' + QuotedStr(TableName) + ') '+ 1599 'order by '+ 1600 'ind.rdb$index_name;'); 1601 open; 1602 end; 1603 while not qry.eof do with IndexDefs.AddIndexDef do 1604 begin 1605 Name := trim(qry.fields[0].asstring); 1606 Fields := trim(qry.Fields[3].asstring); 1607 If qry.fields[4].asstring = 'PRIMARY KEY' then options := options + [ixPrimary]; 1608 If qry.fields[2].asinteger = 1 then options := options + [ixUnique]; 1609 If qry.fields[5].asInteger = 1 then options:=options+[ixDescending]; 1610 qry.next; 1611 while (name = trim(qry.fields[0].asstring)) and (not qry.eof) do 1612 begin 1613 Fields := Fields + ';' + trim(qry.Fields[3].asstring); 1614 qry.next; 1615 end; 1616 end; 1617 qry.close; 1618 qry.free; 1619end; 1620 1621procedure TIBConnection.SetFloat(CurrBuff: pointer; Dbl: Double; Size: integer); 1622 1623var 1624 Ext : extended; 1625 Sin : single; 1626begin 1627 case Size of 1628 4 : 1629 begin 1630 Sin := Dbl; 1631 Move(Sin, CurrBuff^, 4); 1632 end; 1633 8 : 1634 begin 1635 Move(Dbl, CurrBuff^, 8); 1636 end; 1637 10: 1638 begin 1639 Ext := Dbl; 1640 Move(Ext, CurrBuff^, 10); 1641 end; 1642 else 1643 Raise EIBDatabaseError.CreateFmt('Invalid float size for float encode : %d',[Size]); 1644 end; 1645end; 1646 1647procedure TIBConnection.GetFloat(CurrBuff, Buffer: pointer; Size: Byte); 1648var 1649 Ext : extended; 1650 Dbl : double; 1651 Sin : single; 1652begin 1653 case Size of 1654 4 : 1655 begin 1656 Move(CurrBuff^, Sin, 4); 1657 Dbl := Sin; 1658 end; 1659 8 : 1660 begin 1661 Move(CurrBuff^, Dbl, 8); 1662 end; 1663 10: 1664 begin 1665 Move(CurrBuff^, Ext, 10); 1666 Dbl := double(Ext); 1667 end; 1668 else 1669 Raise EIBDatabaseError.CreateFmt('Invalid float size for float Decode : %d',[Size]); 1670 end; 1671 Move(Dbl, Buffer^, 8); 1672end; 1673 1674procedure TIBConnection.LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); 1675const 1676 isc_segstr_eof = 335544367; // It's not defined in ibase60 but in ibase40. Would it be better to define in ibase60? 1677 1678var 1679 blobHandle : Isc_blob_Handle; 1680 blobSegment : pointer; 1681 blobSegLen : word; 1682 TransactionHandle : pointer; 1683 blobId : PISC_QUAD; 1684 ptr : Pointer; 1685begin 1686 // A Blob ID is a unique numeric value that references Blob data. Blob ID is stored in a field in the table 1687 // The first 4 bytes of Blob ID represent the relation id for the blob, the second four bytes represent the id of the blob within the table. 1688 // When new blob is written new Blob ID is assigned to field 1689 blobId := PISC_QUAD(@(ABlobBuf^.ConnBlobBuffer)); 1690 1691 TransactionHandle := Atransaction.Handle; 1692 blobHandle := FB_API_NULLHANDLE; 1693 1694 if isc_open_blob(@FStatus[0], @FDatabaseHandle, @TransactionHandle, @blobHandle, blobId) <> 0 then 1695 CheckError('TIBConnection.CreateBlobStream', FStatus); 1696 1697 //For performance, read as much as we can, regardless of any segment size set in database. 1698 blobSegment := AllocMem(MAXBLOBSEGMENTSIZE); 1699 1700 with ABlobBuf^.BlobBuffer^ do 1701 begin 1702 Size := 0; 1703 while (isc_get_segment(@FStatus[0], @blobHandle, @blobSegLen, MAXBLOBSEGMENTSIZE, blobSegment) = 0) do 1704 begin 1705 ReAllocMem(Buffer,Size+blobSegLen); 1706 ptr := Buffer+Size; 1707 move(blobSegment^,ptr^,blobSegLen); 1708 inc(Size,blobSegLen); 1709 end; 1710 freemem(blobSegment); 1711 1712 if FStatus[1] = isc_segstr_eof then 1713 begin 1714 if isc_close_blob(@FStatus[0], @blobHandle) <> 0 then 1715 CheckError('TIBConnection.CreateBlobStream isc_close_blob', FStatus); 1716 end 1717 else 1718 CheckError('TIBConnection.CreateBlobStream isc_get_segment', FStatus); 1719 end; 1720end; 1721 1722function TIBConnection.RowsAffected(cursor: TSQLCursor): TRowsCount; 1723 1724var info_request : string; 1725 resbuf : array[0..63] of byte; 1726 i : integer; 1727 BlockSize, 1728 subBlockSize : integer; 1729 SelectedRows, 1730 InsertedRows : integer; 1731 1732begin 1733 SelectedRows:=-1; 1734 InsertedRows:=-1; 1735 1736 if assigned(cursor) then with cursor as TIBCursor do 1737 if assigned(StatementHandle) then 1738 begin 1739 info_request := chr(isc_info_sql_records); 1740 if isc_dsql_sql_info(@Status[0], @StatementHandle, Length(info_request), @info_request[1],sizeof(resbuf),@resbuf) <> 0 then 1741 CheckError('RowsAffected', Status); 1742 1743 i := 0; 1744 while not (byte(resbuf[i]) in [isc_info_end,isc_info_truncated]) do 1745 begin 1746 BlockSize:=isc_vax_integer(@resbuf[i+1],2); 1747 if resbuf[i]=isc_info_sql_records then 1748 begin 1749 inc(i,3); 1750 BlockSize:=BlockSize+i; 1751 while (resbuf[i] <> isc_info_end) and (i < BlockSize) do 1752 begin 1753 subBlockSize:=isc_vax_integer(@resbuf[i+1],2); 1754 if resbuf[i] = isc_info_req_select_count then 1755 SelectedRows := isc_vax_integer(@resbuf[i+3],subBlockSize) 1756 else if resbuf[i] = isc_info_req_insert_count then 1757 InsertedRows := isc_vax_integer(@resbuf[i+3],subBlockSize); 1758 inc(i,subBlockSize+3); 1759 end; 1760 end 1761 else 1762 inc(i,BlockSize+3); 1763 end; 1764 end; 1765 if SelectedRows>0 then result:=SelectedRows 1766 else Result:=InsertedRows; 1767end; 1768 1769{ TIBConnectionDef } 1770 1771class function TIBConnectionDef.TypeName: String; 1772begin 1773 Result:='Firebird'; 1774end; 1775 1776class function TIBConnectionDef.ConnectionClass: TSQLConnectionClass; 1777begin 1778 Result:=TIBConnection; 1779end; 1780 1781class function TIBConnectionDef.Description: String; 1782begin 1783 Result:='Connect to Firebird/Interbase directly via the client library'; 1784end; 1785 1786class function TIBConnectionDef.DefaultLibraryName: String; 1787begin 1788{$IFDEF LinkDynamically} 1789 If UseEmbeddedFirebird then 1790 Result:=fbembedlib 1791 else 1792 Result:=fbclib; 1793{$ELSE} 1794 Result:=''; 1795{$ENDIF} 1796end; 1797 1798class function TIBConnectionDef.LoadFunction: TLibraryLoadFunction; 1799begin 1800{$IFDEF LinkDynamically} 1801 Result:=@InitialiseIBase60; 1802{$ELSE} 1803 Result:=nil; 1804{$ENDIF} 1805end; 1806 1807class function TIBConnectionDef.UnLoadFunction: TLibraryUnLoadFunction; 1808begin 1809{$IFDEF LinkDynamically} 1810 Result:=@ReleaseIBase60 1811{$ELSE} 1812 Result:=nil; 1813{$ENDIF} 1814end; 1815 1816class function TIBConnectionDef.LoadedLibraryName: string; 1817begin 1818{$IFDEF LinkDynamically} 1819 Result:=IBaseLoadedLibrary; 1820{$ELSE} 1821 Result:=''; 1822{$ENDIF} 1823end; 1824 1825initialization 1826 RegisterConnection(TIBConnectionDef); 1827 1828finalization 1829 UnRegisterConnection(TIBConnectionDef); 1830end. 1831