client/2.5/FB25ClientAPI.pas

(*
 *  Firebird Interface (fbintf). The fbintf components provide a set of
 *  Pascal language bindings for the Firebird API. Although predominantly
 *  a new development they include source code taken from IBX and may be
 *  considered a derived product. This software thus also includes the copyright
 *  notice and license conditions from IBX.
 *
 *  Except for those parts dervied from IBX, contents of this file are subject
 *  to the Initial Developer's Public License Version 1.0 (the "License"); you
 *  may not use this file except in compliance with the License. You may obtain a
 *  copy of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2016 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You            }
{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{    IBX For Lazarus (Firebird Express)                                  }
{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
{    Portions created by MWA Software are copyright McCallum Whyman      }
{    Associates Ltd 2011 - 2015                                                }
{                                                                        }
{************************************************************************}
unit FB25ClientAPI;
{$IFDEF MSWINDOWS} 
{$DEFINE WINDOWS} 
{$ENDIF}

{$IFDEF FPC}
{$mode delphi}
{$interfaces COM}
{$ENDIF}

interface

uses
  Classes, SysUtils, FBClientAPI, IBHeader, IBExternals, IB;

const
  FBClientInterfaceVersion = '2.5';

type

  { TFB25Status }

  TFB25Status = class(TFBStatus,IStatus)
  public
    function StatusVector: PStatusVector; override;
  end;

  { TFB25ClientAPI }

  TFB25ClientAPI = class(TFBClientAPI,IFirebirdAPI)
  private
    FIBServiceAPIPresent: boolean;
    FStatus: TFB25Status;
    FStatusIntf: IStatus;   {Keep a reference to the interface - automatic destroy
                             when this class is freed and last reference to IStatus
                             goes out of scope.}
  protected
    {$IFDEF UNIX}
    function GetFirebirdLibList: string; override;
    {$ENDIF}
    procedure LoadInterface; override;
  public
    constructor Create;
    destructor Destroy; override;
    function StatusVector: PISC_STATUS;
    property IBServiceAPIPresent: boolean read FIBServiceAPIPresent;
    property Status: TFB25Status read FStatus;

  public

    {fbclient API}
    BLOB_get: TBLOB_get;
    BLOB_put: TBLOB_put;
    isc_wait_for_event: Tisc_wait_for_event;
    isc_vax_integer: Tisc_vax_integer;
    isc_portable_integer: Tisc_portable_integer;
    isc_blob_info: Tisc_blob_info;
    isc_blob_lookup_desc: Tisc_blob_lookup_desc;
    isc_open_blob2: Tisc_open_blob2;
    isc_close_blob: Tisc_close_blob;
    isc_get_segment: Tisc_get_segment;
    isc_put_segment: Tisc_put_segment;
    isc_create_blob2: Tisc_create_blob2;
    isc_cancel_blob: Tisc_cancel_blob;
    isc_service_attach: Tisc_service_attach;
    isc_service_detach: Tisc_service_detach;
    isc_service_query: Tisc_service_query;
    isc_service_start: Tisc_service_start;
    isc_decode_date: Tisc_decode_date;
    isc_decode_sql_date: Tisc_decode_sql_date;
    isc_decode_sql_time: Tisc_decode_sql_time;
    isc_decode_timestamp: Tisc_decode_timestamp;
    isc_encode_date: Tisc_encode_date;
    isc_encode_sql_date: Tisc_encode_sql_date;
    isc_encode_sql_time: Tisc_encode_sql_time;
    isc_encode_timestamp: Tisc_encode_timestamp;
    isc_dsql_free_statement: Tisc_dsql_free_statement;
    isc_dsql_execute2: Tisc_dsql_execute2;
    isc_dsql_execute: Tisc_dsql_execute;
    isc_dsql_set_cursor_name: Tisc_dsql_set_cursor_name;
    isc_dsql_fetch: Tisc_dsql_fetch;
    isc_dsql_sql_info: Tisc_dsql_sql_info;
    isc_dsql_alloc_statement2: Tisc_dsql_alloc_statement2;
    isc_dsql_prepare: Tisc_dsql_prepare;
    isc_dsql_describe_bind: Tisc_dsql_describe_bind;
    isc_dsql_describe: Tisc_dsql_describe;
    isc_dsql_execute_immediate: Tisc_dsql_execute_immediate;
    isc_drop_database: Tisc_drop_database;
    isc_detach_database: Tisc_detach_database;
    isc_attach_database: Tisc_attach_database;
    isc_database_info: Tisc_database_info;
    isc_start_transaction: Tisc_start_transaction;
    isc_start_multiple: Tisc_start_multiple;
    isc_commit_transaction: Tisc_commit_transaction;
    isc_commit_retaining: Tisc_commit_retaining;
    isc_rollback_transaction: Tisc_rollback_transaction;
    isc_rollback_retaining: Tisc_rollback_retaining;
    isc_cancel_events: Tisc_cancel_events;
    isc_que_events: Tisc_que_events;
    isc_add_user   : Tisc_add_user;
    isc_delete_user: Tisc_delete_user;
    isc_modify_user: Tisc_modify_user;
    isc_array_lookup_bounds: Tisc_array_lookup_bounds;
    isc_array_get_slice: Tisc_array_get_slice;
    isc_array_put_slice: Tisc_array_put_slice;
    isc_prepare_transaction: Tisc_prepare_transaction;

  public
    {Helper Functions}
    function DecodeInteger(bufptr: PByte; len: short): integer; override;
    procedure SQLEncodeDate(aDate: TDateTime; bufptr: PByte); override;
    function SQLDecodeDate(bufptr: PByte): TDateTime; override;
    procedure SQLEncodeTime(aTime: TDateTime; bufptr: PByte); override;
    function SQLDecodeTime(bufptr: PByte): TDateTime;  override;
    procedure SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte); override;
    function SQLDecodeDateTime(bufptr: PByte): TDateTime; override;

  public
    {IFirebirdAPI}

    {Database connections}
    function AllocateDPB: IDPB;
    function OpenDatabase(DatabaseName: AnsiString; DPB: IDPB; RaiseExceptionOnConnectError: boolean=true): IAttachment;
    function CreateDatabase(DatabaseName: AnsiString; DPB: IDPB; RaiseExceptionOnError: boolean=true): IAttachment;  overload;
    function CreateDatabase(sql: AnsiString; aSQLDialect: integer; RaiseExceptionOnError: boolean=true): IAttachment; overload;

    {Start Transaction against multiple databases}
    function AllocateTPB: ITPB;
    function StartTransaction(Attachments: array of IAttachment;
             TPB: array of byte; DefaultCompletion: TTransactionCompletion): ITransaction; overload;
    function StartTransaction(Attachments: array of IAttachment;
             TPB: ITPB; DefaultCompletion: TTransactionCompletion): ITransaction; overload;

    {Service Manager}
    function AllocateSPB: ISPB;
    function HasServiceAPI: boolean;
    function GetServiceManager(ServerName: AnsiString; Protocol: TProtocol; SPB: ISPB): IServiceManager; overload;
    function GetServiceManager(ServerName: AnsiString; Port: AnsiString; Protocol: TProtocol; SPB: ISPB): IServiceManager; overload;

    {Information}
    function GetStatus: IStatus; override;
    function HasRollbackRetaining: boolean;
    function IsEmbeddedServer: boolean; override;
    function GetImplementationVersion: AnsiString;

    {Firebird 3 API}
    function HasMasterIntf: boolean;
    function GetIMaster: TObject;

   end;

var
  Firebird25ClientAPI: TFB25ClientAPI = nil;

implementation

uses FBMessages,
    {$IFDEF WINDOWS}Windows, {$ENDIF}
    {$IFDEF FPC} Dynlibs, {$ENDIF}
  FB25Attachment, FB25Transaction, FB25Services, FBParamBlock,
  IBUtils;

{ Stubs for 6.0 only functions }
function isc_rollback_retaining_stub(status_vector   : PISC_STATUS;
              tran_handle     : PISC_TR_HANDLE):
                                     ISC_STATUS; {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  Result := 0;
  IBError(ibxeIB60feature, ['isc_rollback_retaining']); {do not localize}
end;

function isc_service_attach_stub(status_vector      : PISC_STATUS;
                                 isc_arg2           : UShort;
                                 isc_arg3           : PAnsiChar;
                                 service_handle     : PISC_SVC_HANDLE;
                                 isc_arg5           : UShort;
                                 isc_arg6           : PAnsiChar):
                                 ISC_STATUS; {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  Result := 0;
  IBError(ibxeIB60feature, ['isc_service_attach']); {do not localize}
end;

function isc_service_detach_stub(status_vector      : PISC_STATUS;
                                 service_handle     : PISC_SVC_HANDLE):
                                 ISC_STATUS; {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  Result := 0;
  IBError(ibxeIB60feature, ['isc_service_detach']); {do not localize}
end;

function isc_service_query_stub(status_vector        : PISC_STATUS;
                                service_handle       : PISC_SVC_HANDLE;
                                recv_handle          : PISC_SVC_HANDLE;
                                isc_arg4             : UShort;
                                isc_arg5             : PAnsiChar;
                                isc_arg6             : UShort;
                                isc_arg7             : PAnsiChar;
                                isc_arg8             : UShort;
                                isc_arg9             : PAnsiChar):
                                ISC_STATUS; {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  Result := 0;
  IBError(ibxeIB60feature, ['isc_service_query']); {do not localize}
end;

function isc_service_start_stub(status_vector        : PISC_STATUS;
                                service_handle       : PISC_SVC_HANDLE;
                                recv_handle          : PISC_SVC_HANDLE;
                                isc_arg4             : UShort;
                                isc_arg5             : PAnsiChar):
                                ISC_STATUS; {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  Result := 0;
  IBError(ibxeIB60feature, ['isc_service_start']); {do not localize}
end;

procedure isc_encode_sql_date_stub(tm_date           : PCTimeStructure;
                 ib_date           : PISC_DATE);
                                   {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  IBError(ibxeIB60feature, ['isc_encode_sql_date']); {do not localize}
end;

procedure isc_encode_sql_time_stub(tm_date           : PCTimeStructure;
                   ib_time           : PISC_TIME);
                                   {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  IBError(ibxeIB60feature, ['isc_encode_sql_time']); {do not localize}
end;

procedure isc_encode_timestamp_stub(tm_date          : PCTimeStructure;
                  ib_timestamp     : PISC_TIMESTAMP);
                                    {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  IBError(ibxeIB60feature, ['isc_encode_sql_timestamp']); {do not localize}
end;

procedure isc_decode_sql_date_stub(ib_date           : PISC_DATE;
                                   tm_date           : PCTimeStructure);
                                   {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  IBError(ibxeIB60feature, ['isc_decode_sql_date']); {do not localize}
end;

procedure isc_decode_sql_time_stub(ib_time           : PISC_TIME;
                                   tm_date           : PCTimeStructure);
                                   {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  IBError(ibxeIB60feature, ['isc_decode_sql_time']); {do not localize}
end;

procedure isc_decode_timestamp_stub(ib_timestamp     : PISC_TIMESTAMP;
                                    tm_date          : PCTimeStructure);
                                    {$IFDEF WINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF}
begin
  IBError(ibxeIB60feature, ['isc_decode_timestamp']); {do not localize}
end;

{ TFB25Status }

threadvar
  FStatusVector: TStatusVector;

function TFB25Status.StatusVector: PStatusVector;
begin
  Result := @FStatusVector;
end;


{ TFB25ClientAPI }

{$IFDEF UNIX}
function TFB25ClientAPI.GetFirebirdLibList: string;
begin
  Result := 'libfbembed.so:libfbembed.so.2.5:libfbembed.so.2.1:libfbclient.so:libfbclient.so.2';
end;
{$ENDIF}

procedure TFB25ClientAPI.LoadInterface;
begin
  inherited LoadInterface;
  BLOB_get := GetProcAddr('BLOB_get'); {do not localize}
  BLOB_put := GetProcAddr('BLOB_put'); {do not localize}
  isc_wait_for_event := GetProcAddr('isc_wait_for_event'); {do not localize}
  isc_vax_integer := GetProcAddr('isc_vax_integer'); {do not localize}
  isc_portable_integer := GetProcAddr('isc_portable_integer'); {do not localize}
  isc_blob_info := GetProcAddr('isc_blob_info'); {do not localize}
  isc_blob_lookup_desc := GetProcAddr('isc_blob_lookup_desc');  {do not localize}
  isc_open_blob2 := GetProcAddr('isc_open_blob2'); {do not localize}
  isc_close_blob := GetProcAddr('isc_close_blob'); {do not localize}
  isc_get_segment := GetProcAddr('isc_get_segment'); {do not localize}
  isc_put_segment := GetProcAddr('isc_put_segment'); {do not localize}
  isc_create_blob2 := GetProcAddr('isc_create_blob2'); {do not localize}
  isc_cancel_blob :=  GetProcAddr('isc_cancel_blob'); {do not localize}
  isc_decode_date := GetProcAddr('isc_decode_date'); {do not localize}
  isc_encode_date := GetProcAddr('isc_encode_date'); {do not localize}
  isc_dsql_free_statement := GetProcAddr('isc_dsql_free_statement'); {do not localize}
  isc_dsql_execute2 := GetProcAddr('isc_dsql_execute2'); {do not localize}
  isc_dsql_execute := GetProcAddr('isc_dsql_execute'); {do not localize}
  isc_dsql_set_cursor_name := GetProcAddr('isc_dsql_set_cursor_name'); {do not localize}
  isc_dsql_fetch := GetProcAddr('isc_dsql_fetch'); {do not localize}
  isc_dsql_sql_info := GetProcAddr('isc_dsql_sql_info'); {do not localize}
  isc_dsql_alloc_statement2 := GetProcAddr('isc_dsql_alloc_statement2'); {do not localize}
  isc_dsql_prepare := GetProcAddr('isc_dsql_prepare'); {do not localize}
  isc_dsql_describe_bind := GetProcAddr('isc_dsql_describe_bind'); {do not localize}
  isc_dsql_describe := GetProcAddr('isc_dsql_describe'); {do not localize}
  isc_dsql_execute_immediate := GetProcAddr('isc_dsql_execute_immediate'); {do not localize}
  isc_drop_database := GetProcAddr('isc_drop_database'); {do not localize}
  isc_detach_database := GetProcAddr('isc_detach_database'); {do not localize}
  isc_attach_database := GetProcAddr('isc_attach_database'); {do not localize}
  isc_database_info := GetProcAddr('isc_database_info'); {do not localize}
  isc_start_transaction := GetProcAddr('isc_start_transaction'); {do not localize}
  isc_start_multiple := GetProcAddr('isc_start_multiple'); {do not localize}
  isc_commit_transaction := GetProcAddr('isc_commit_transaction'); {do not localize}
  isc_commit_retaining := GetProcAddr('isc_commit_retaining'); {do not localize}
  isc_rollback_transaction := GetProcAddr('isc_rollback_transaction'); {do not localize}
  isc_cancel_events := GetProcAddr('isc_cancel_events'); {do not localize}
  isc_que_events := GetProcAddr('isc_que_events'); {do not localize}
  isc_add_user := GetProcAddr('isc_add_user'); {do not localize}
  isc_delete_user := GetProcAddr('isc_delete_user'); {do not localize}
  isc_modify_user := GetProcAddr('isc_modify_user'); {do not localize}
  isc_array_lookup_bounds := GetProcAddr('isc_array_lookup_bounds'); {do not localize}
  isc_array_get_slice := GetProcAddr('isc_array_get_slice'); {do not localize}
  isc_array_put_slice := GetProcAddr('isc_array_put_slice'); {do not localize}
  isc_prepare_transaction  := GetProcAddr('isc_prepare_transaction'); {do not localize}

  FIBServiceAPIPresent := true;
  isc_rollback_retaining := GetProcAddress(IBLibrary, 'isc_rollback_retaining'); {do not localize}
  if Assigned(isc_rollback_retaining) then
  begin
    isc_service_attach := GetProcAddr('isc_service_attach'); {do not localize}
    isc_service_detach := GetProcAddr('isc_service_detach'); {do not localize}
    isc_service_query := GetProcAddr('isc_service_query'); {do not localize}
    isc_service_start := GetProcAddr('isc_service_start'); {do not localize}
    isc_decode_sql_date := GetProcAddr('isc_decode_sql_date'); {do not localize}
    isc_decode_sql_time := GetProcAddr('isc_decode_sql_time'); {do not localize}
    isc_decode_timestamp := GetProcAddr('isc_decode_timestamp'); {do not localize}
    isc_encode_sql_date := GetProcAddr('isc_encode_sql_date'); {do not localize}
    isc_encode_sql_time := GetProcAddr('isc_encode_sql_time'); {do not localize}
    isc_encode_timestamp := GetProcAddr('isc_encode_timestamp'); {do not localize}
  end else
  begin
    FIBServiceAPIPresent := false;
    isc_rollback_retaining := @isc_rollback_retaining_stub;
    isc_service_attach := @isc_service_attach_stub;
    isc_service_detach := @isc_service_detach_stub;
    isc_service_query := @isc_service_query_stub;
    isc_service_start := @isc_service_start_stub;
    isc_decode_sql_date := @isc_decode_sql_date_stub;
    isc_decode_sql_time := @isc_decode_sql_time_stub;
    isc_decode_timestamp := @isc_decode_timestamp_stub;
    isc_encode_sql_date := @isc_encode_sql_date_stub;
    isc_encode_sql_time := @isc_encode_sql_time_stub;
    isc_encode_timestamp := @isc_encode_timestamp_stub;
  end;
end;

constructor TFB25ClientAPI.Create;
begin
  inherited;
  FStatus := TFB25Status.Create(self);
  FStatusIntf := FStatus;
  Firebird25ClientAPI := self;
end;

destructor TFB25ClientAPI.Destroy;
begin
  FStatusIntf := nil;
  Firebird25ClientAPI := nil;
  inherited Destroy;
end;


function TFB25ClientAPI.StatusVector: PISC_STATUS;
begin
  Result := PISC_STATUS(FStatus.StatusVector);
end;

function TFB25ClientAPI.GetStatus: IStatus;
begin
  Result := FStatus;
end;

function TFB25ClientAPI.AllocateDPB: IDPB;
begin
  Result := TDPB.Create;
end;

function TFB25ClientAPI.OpenDatabase(DatabaseName: AnsiString; DPB: IDPB;
                                    RaiseExceptionOnConnectError: boolean): IAttachment;
begin
   Result := TFB25Attachment.Create(DatabaseName,DPB,RaiseExceptionOnConnectError);
   if not Result.IsConnected then
     Result := nil;
end;

function TFB25ClientAPI.CreateDatabase(DatabaseName: AnsiString; DPB: IDPB;
  RaiseExceptionOnError: boolean): IAttachment;
begin
  Result := TFB25Attachment.CreateDatabase(DatabaseName, DPB, RaiseExceptionOnError );
   if (Result <> nil) and not Result.IsConnected then
     Result := nil;
end;

function TFB25ClientAPI.CreateDatabase(sql: AnsiString; aSQLDialect: integer;
  RaiseExceptionOnError: boolean): IAttachment;
begin
  Result := TFB25Attachment.CreateDatabase(sql,aSQLDialect, RaiseExceptionOnError );
   if (Result <> nil) and not Result.IsConnected then
     Result := nil;
end;

function TFB25ClientAPI.AllocateSPB: ISPB;
begin
  Result := TSPB.Create;
end;

function TFB25ClientAPI.AllocateTPB: ITPB;
begin
  Result := TTPB.Create;
end;

function TFB25ClientAPI.GetServiceManager(ServerName: AnsiString;
  Protocol: TProtocol; SPB: ISPB): IServiceManager;
begin
  if HasServiceAPI then
    Result := TFB25ServiceManager.Create(ServerName,Protocol,SPB)
  else
    Result := nil;
end;

function TFB25ClientAPI.GetServiceManager(ServerName: AnsiString;
  Port: AnsiString; Protocol: TProtocol; SPB: ISPB): IServiceManager;
begin
  if HasServiceAPI then
    Result := TFB25ServiceManager.Create(ServerName,Protocol,SPB,Port)
  else
    Result := nil;
end;

function TFB25ClientAPI.StartTransaction(Attachments: array of IAttachment;
  TPB: array of byte; DefaultCompletion: TTransactionCompletion): ITransaction;
begin
  Result := TFB25Transaction.Create(Attachments,TPB,DefaultCompletion);
end;

function TFB25ClientAPI.StartTransaction(Attachments: array of IAttachment;
  TPB: ITPB; DefaultCompletion: TTransactionCompletion): ITransaction;
begin
  Result := TFB25Transaction.Create(Attachments,TPB,DefaultCompletion);
end;

function TFB25ClientAPI.HasServiceAPI: boolean;
begin
  Result := IBServiceAPIPresent;
end;

function TFB25ClientAPI.HasRollbackRetaining: boolean;
begin
  Result := assigned(isc_rollback_retaining);
end;

function TFB25ClientAPI.IsEmbeddedServer: boolean;
begin
  Result := false;
{$IFDEF UNIX}
  Result := Pos('libfbembed',FFBLibraryName) = 1;
{$ENDIF}
{$IFDEF WINDOWS}
  Result := CompareText(FFBLibraryName,FIREBIRD_EMBEDDED) = 0;
{$ENDIF}
end;

function TFB25ClientAPI.HasMasterIntf: boolean;
begin
  Result := false;
end;

function TFB25ClientAPI.GetIMaster: TObject;
begin
  Result := nil;
end;

function TFB25ClientAPI.GetImplementationVersion: AnsiString;
begin
  Result := FBClientInterfaceVersion;
end;

function TFB25ClientAPI.DecodeInteger(bufptr: PByte; len: short): integer;
begin
  Result := isc_portable_integer(bufptr,len);
end;

procedure TFB25ClientAPI.SQLEncodeDate(aDate: TDateTime; bufptr: PByte);
var
  tm_date: TCTimeStructure;
  Yr, Mn, Dy: Word;
begin
  DecodeDate(aDate, Yr, Mn, Dy);
  with tm_date do begin
    tm_sec := 0;
    tm_min := 0;
    tm_hour := 0;
    tm_mday := Dy;
    tm_mon := Mn - 1;
    tm_year := Yr - 1900;
  end;
  isc_encode_sql_date(@tm_date, PISC_DATE(bufptr));
end;

function TFB25ClientAPI.SQLDecodeDate(bufptr: PByte): TDateTime;
var
  tm_date: TCTimeStructure;
begin
  isc_decode_sql_date(PISC_DATE(bufptr), @tm_date);
  try
    result := EncodeDate(Word(tm_date.tm_year + 1900), Word(tm_date.tm_mon + 1),
                         Word(tm_date.tm_mday));
  except
    on E: EConvertError do begin
      IBError(ibxeInvalidDataConversion, [nil]);
    end;
  end;
end;

procedure TFB25ClientAPI.SQLEncodeTime(aTime: TDateTime; bufptr: PByte);
var
  tm_date: TCTimeStructure;
  Hr, Mt, S, Ms: Word;
begin
  DecodeTime(aTime, Hr, Mt, S, Ms);
  with tm_date do begin
    tm_sec := S;
    tm_min := Mt;
    tm_hour := Hr;
    tm_mday := 0;
    tm_mon := 0;
    tm_year := 0;
  end;
  with Firebird25ClientAPI do
    isc_encode_sql_time(@tm_date, PISC_TIME(bufptr));
  if Ms > 0 then
    Inc(PISC_TIME(bufptr)^,Ms*10);
end;

function TFB25ClientAPI.SQLDecodeTime(bufptr: PByte): TDateTime;
var
  tm_date: TCTimeStructure;
  msecs: Word;
begin
  isc_decode_sql_time(PISC_TIME(bufptr), @tm_date);
  try
    msecs :=  (PISC_TIME(bufptr)^ mod 10000) div 10;
    result := EncodeTime(Word(tm_date.tm_hour), Word(tm_date.tm_min),
                         Word(tm_date.tm_sec), msecs)
  except
    on E: EConvertError do begin
      IBError(ibxeInvalidDataConversion, [nil]);
    end;
  end;
end;

procedure TFB25ClientAPI.SQLEncodeDateTime(aDateTime: TDateTime; bufptr: PByte);
var
  tm_date: TCTimeStructure;
  Yr, Mn, Dy, Hr, Mt, S, Ms: Word;
begin
  DecodeDate(aDateTime, Yr, Mn, Dy);
  DecodeTime(aDateTime, Hr, Mt, S, Ms);
  with tm_date do begin
    tm_sec := S;
    tm_min := Mt;
    tm_hour := Hr;
    tm_mday := Dy;
    tm_mon := Mn - 1;
    tm_year := Yr - 1900;
  end;
  isc_encode_date(@tm_date, PISC_QUAD(bufptr));
  if Ms > 0 then
    Inc(PISC_TIMESTAMP(bufptr)^.timestamp_time,Ms*10);
end;

function TFB25ClientAPI.SQLDecodeDateTime(bufptr: PByte): TDateTime;
var
  tm_date: TCTimeStructure;
  msecs: Word;
begin
  isc_decode_date(PISC_QUAD(bufptr), @tm_date);
  try
    result := EncodeDate(Word(tm_date.tm_year + 1900), Word(tm_date.tm_mon + 1),
                        Word(tm_date.tm_mday));
    msecs := (PISC_TIMESTAMP(bufptr)^.timestamp_time mod 10000) div 10;
    if result >= 0 then
      result := result + EncodeTime(Word(tm_date.tm_hour), Word(tm_date.tm_min),
                                    Word(tm_date.tm_sec), msecs)
    else
      result := result - EncodeTime(Word(tm_date.tm_hour), Word(tm_date.tm_min),
                                    Word(tm_date.tm_sec), msecs)
  except
    on E: EConvertError do begin
      IBError(ibxeInvalidDataConversion, [nil]);
    end;
  end;
end;

end.


Revision:	143
Committed:	Fri Feb 23 12:11:21 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	25748 byte(s)
Log Message:	Fixes Merged