client/2.5/FB25Array.pas

(*
 *  Firebird Interface (fbintf). The fbintf components provide a set of
 *  Pascal language bindings for the Firebird API.
 *
 *  The 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): ______________________________________.
 *
*)
unit FB25Array;
{$IFDEF MSWINDOWS} 
{$DEFINE WINDOWS} 
{$ENDIF}

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

interface

uses
  Classes, SysUtils, IB, FBArray, IBHeader, FB25Statement, FB25Attachment, FBClientAPI,
  FB25Transaction, FB25ClientAPI;

type

  { TFB25ArrayMetaData }

  TFB25ArrayMetaData = class(TFBArrayMetaData,IArrayMetaData)
  private
    FCodePage: TSystemCodePage;
    FCharSetWidth: integer;
  protected
    procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
                   relationName, columnName: AnsiString); override;
  public
    function GetCharSetID: cardinal; override;
    function GetCodePage: TSystemCodePage; override;
    function GetCharSetWidth: integer; override;
  end;

  { TFB25Array }

  TFB25Array = class(TFBArray,IArray)
  private
    FDBHandle: TISC_DB_HANDLE;
    FTRHandle: TISC_TR_HANDLE;
    FFirebird25ClientAPI: TFB25ClientAPI;
  protected
    procedure InternalGetSlice; override;
    procedure InternalPutSlice(Force: boolean); override;
  public
    constructor Create(aAttachment: TFB25Attachment; aTransaction: TFB25Transaction; aField: IArrayMetaData); overload;
    constructor Create(aAttachment: TFB25Attachment; aTransaction: TFB25Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD); overload;
 end;

implementation

uses FBAttachment;

const
  sGetArrayMetaData = 'Select F.RDB$CHARACTER_SET_ID '+
                      'From RDB$FIELDS F JOIN RDB$RELATION_FIELDS RF '+
                      'On F.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE '+
                      'Where RF.RDB$RELATION_NAME = ? and RF.RDB$FIELD_NAME = ? '+
                      'UNION '+
                      'Select F.RDB$CHARACTER_SET_ID '+
                      'From RDB$FIELDS F JOIN RDB$PROCEDURE_PARAMETERS PP '+
                      'On F.RDB$FIELD_NAME = PP.RDB$FIELD_SOURCE '+
                      'Where PP.RDB$PROCEDURE_NAME = ? and PP.RDB$PARAMETER_NAME = ?';

  { TFB25ArrayMetaData }

procedure TFB25ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
  aTransaction: ITransaction; relationName, columnName: AnsiString);
var
  DBHandle: TISC_DB_HANDLE;
  TRHandle: TISC_TR_HANDLE;
  stmt: IStatement;
  CharWidth: integer;
  RelName: AnsiString;
  ColName: AnsiString;
begin
  DBHandle := (aAttachment as TFB25Attachment).Handle;
  TRHandle := (aTransaction as TFB25Transaction).Handle;
  RelName := AnsiUpperCase(relationName);
  ColName := AnsiUpperCase(columnName);
  with (aAttachment as TFB25Attachment).Firebird25ClientAPI do
    if isc_array_lookup_bounds(StatusVector,@(DBHandle),@(TRHandle),
        PAnsiChar(RelName),PAnsiChar(ColName),@FArrayDesc) > 0 then
          IBDatabaseError;

  if (GetSQLType = SQL_TEXT) or (GetSQLType = SQL_VARYING) then
  begin
    stmt := TFB25Statement.Create(aAttachment as TFB25Attachment,aTransaction,
                                 sGetArrayMetaData ,aAttachment.GetSQLDialect);
    with stmt do
    begin
      SQLParams[0].AsString := RelationName;
      SQLParams[1].AsString := ColumnName;
      SQLParams[2].AsString := RelationName;
      SQLParams[3].AsString := ColumnName;
      with OpenCursor do
      if FetchNext then
      begin
        FCharSetID := Data[0].AsInteger;
        FCharSetWidth := 1;
        with (aAttachment as TFB25Attachment) do
        if (FCharSetID > 1) and HasDefaultCharSet then
        begin
          FCharSetID := CharSetID;
          FCodePage := CodePage;
        end
        else
        begin
          FCodePage := CP_NONE;
          FAttachment.CharSetID2CodePage(FCharSetID,FCodePage);
          FAttachment.CharSetWidth(FCharSetID,FCharSetWidth);
        end;
      end;
    end;
  end;
  if (FArrayDesc.array_desc_dtype in [blr_text,blr_cstring, blr_varying]) and
      (FCharSetID = 0) then {This really shouldn't be necessary - but it is :(}
  with aAttachment as TFBAttachment do
  begin
    if HasDefaultCharSet  and FAttachment.CharSetWidth(CharSetID,CharWidth) then
      FArrayDesc.array_desc_length := FArrayDesc.array_desc_length * CharWidth;
  end;
end;

function TFB25ArrayMetaData.GetCharSetID: cardinal;
begin
  Result := FCharSetID;
end;

function TFB25ArrayMetaData.GetCodePage: TSystemCodePage;
begin
  Result := FCodePage;
end;

function TFB25ArrayMetaData.GetCharSetWidth: integer;
begin
  Result := FCharSetWidth;
end;

{ TFB25Array }

procedure TFB25Array.InternalGetSlice;
begin
  with FFirebird25ClientAPI do
     Call(isc_array_get_slice(StatusVector,@(FDBHandle),@(FTRHandle),
                                @FArrayID, GetArrayDesc,
                                Pointer(FBuffer), @FBufSize));
end;

procedure TFB25Array.InternalPutSlice(Force: boolean);
begin
  with FFirebird25ClientAPI do
     if (isc_array_put_slice(StatusVector, @(FDBHandle),@(FTRHandle),
                                @FArrayID, GetArrayDesc,
                                Pointer(FBuffer),@FBufSize) > 0) and not Force then
       IBDatabaseError;
  SignalActivity;
end;

constructor TFB25Array.Create(aAttachment: TFB25Attachment;
  aTransaction: TFB25Transaction; aField: IArrayMetaData);
begin
  inherited Create(aAttachment,aTransaction,aField);
  FDBHandle := aAttachment.Handle;
  FTRHandle := aTransaction.Handle;
  FFirebird25ClientAPI := aAttachment.Firebird25ClientAPI;
  OnDatabaseError := FFirebird25ClientAPI.IBDataBaseError;
end;

constructor TFB25Array.Create(aAttachment: TFB25Attachment;
  aTransaction: TFB25Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD);
begin
  inherited Create(aAttachment,aTransaction,aField,ArrayID);
  FDBHandle := aAttachment.Handle;
  FTRHandle := aTransaction.Handle;
  FFirebird25ClientAPI := aAttachment.Firebird25ClientAPI;
  OnDatabaseError := FFirebird25ClientAPI.IBDataBaseError;
end;

end.

Revision:	309
Committed:	Tue Jul 21 08:00:42 2020 UTC (4 years, 4 months ago) by tony
Content type:	text/x-pascal
File size:	6696 byte(s)
Log Message:	Fixes Merged
#	User	Rev	Content
1	tony	45	(*
2			* Firebird Interface (fbintf). The fbintf components provide a set of
3			* Pascal language bindings for the Firebird API.
4			*
5			* The contents of this file are subject to the Initial Developer's
6			* Public License Version 1.0 (the "License"); you may not use this
7			* file except in compliance with the License. You may obtain a copy
8			* of the License here:
9			*
10			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
11			*
12			* Software distributed under the License is distributed on an "AS
13			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
14			* implied. See the License for the specific language governing rights
15			* and limitations under the License.
16			*
17			* The Initial Developer of the Original Code is Tony Whyman.
18			*
19			* The Original Code is (C) 2016 Tony Whyman, MWA Software
20			* (http://www.mwasoftware.co.uk).
21			*
22			* All Rights Reserved.
23			*
24			* Contributor(s): ______________________________________.
25			*
26			*)
27			unit FB25Array;
28	tony	56	{$IFDEF MSWINDOWS}
29			{$DEFINE WINDOWS}
30			{$ENDIF}
31	tony	45
32			{$IFDEF FPC}
33	tony	56	{$mode delphi}
34	tony	45	{$codepage UTF8}
35			{$interfaces COM}
36			{$ENDIF}
37
38			interface
39
40			uses
41			Classes, SysUtils, IB, FBArray, IBHeader, FB25Statement, FB25Attachment, FBClientAPI,
42	tony	263	FB25Transaction, FB25ClientAPI;
43	tony	45
44			type
45
46			{ TFB25ArrayMetaData }
47
48			TFB25ArrayMetaData = class(TFBArrayMetaData,IArrayMetaData)
49			private
50			FCodePage: TSystemCodePage;
51	tony	309	FCharSetWidth: integer;
52	tony	45	protected
53			procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
54	tony	56	relationName, columnName: AnsiString); override;
55	tony	45	public
56			function GetCharSetID: cardinal; override;
57			function GetCodePage: TSystemCodePage; override;
58	tony	309	function GetCharSetWidth: integer; override;
59	tony	45	end;
60
61			{ TFB25Array }
62
63			TFB25Array = class(TFBArray,IArray)
64			private
65			FDBHandle: TISC_DB_HANDLE;
66			FTRHandle: TISC_TR_HANDLE;
67	tony	263	FFirebird25ClientAPI: TFB25ClientAPI;
68	tony	45	protected
69			procedure InternalGetSlice; override;
70			procedure InternalPutSlice(Force: boolean); override;
71			public
72			constructor Create(aAttachment: TFB25Attachment; aTransaction: TFB25Transaction; aField: IArrayMetaData); overload;
73			constructor Create(aAttachment: TFB25Attachment; aTransaction: TFB25Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD); overload;
74			end;
75
76			implementation
77
78	tony	263	uses FBAttachment;
79	tony	45
80			const
81			sGetArrayMetaData = 'Select F.RDB$CHARACTER_SET_ID '+
82			'From RDB$FIELDS F JOIN RDB$RELATION_FIELDS RF '+
83			'On F.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE '+
84	tony	113	'Where RF.RDB$RELATION_NAME = ? and RF.RDB$FIELD_NAME = ? '+
85			'UNION '+
86			'Select F.RDB$CHARACTER_SET_ID '+
87			'From RDB$FIELDS F JOIN RDB$PROCEDURE_PARAMETERS PP '+
88			'On F.RDB$FIELD_NAME = PP.RDB$FIELD_SOURCE '+
89			'Where PP.RDB$PROCEDURE_NAME = ? and PP.RDB$PARAMETER_NAME = ?';
90	tony	45
91			{ TFB25ArrayMetaData }
92
93			procedure TFB25ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
94	tony	56	aTransaction: ITransaction; relationName, columnName: AnsiString);
95	tony	45	var
96			DBHandle: TISC_DB_HANDLE;
97			TRHandle: TISC_TR_HANDLE;
98			stmt: IStatement;
99	tony	47	CharWidth: integer;
100	tony	56	RelName: AnsiString;
101			ColName: AnsiString;
102	tony	45	begin
103			DBHandle := (aAttachment as TFB25Attachment).Handle;
104			TRHandle := (aTransaction as TFB25Transaction).Handle;
105	tony	56	RelName := AnsiUpperCase(relationName);
106			ColName := AnsiUpperCase(columnName);
107	tony	263	with (aAttachment as TFB25Attachment).Firebird25ClientAPI do
108	tony	45	if isc_array_lookup_bounds(StatusVector,@(DBHandle),@(TRHandle),
109	tony	56	PAnsiChar(RelName),PAnsiChar(ColName),@FArrayDesc) > 0 then
110	tony	45	IBDatabaseError;
111
112			if (GetSQLType = SQL_TEXT) or (GetSQLType = SQL_VARYING) then
113			begin
114			stmt := TFB25Statement.Create(aAttachment as TFB25Attachment,aTransaction,
115			sGetArrayMetaData ,aAttachment.GetSQLDialect);
116			with stmt do
117			begin
118			SQLParams[0].AsString := RelationName;
119			SQLParams[1].AsString := ColumnName;
120	tony	113	SQLParams[2].AsString := RelationName;
121			SQLParams[3].AsString := ColumnName;
122	tony	45	with OpenCursor do
123			if FetchNext then
124			begin
125			FCharSetID := Data[0].AsInteger;
126	tony	309	FCharSetWidth := 1;
127	tony	45	with (aAttachment as TFB25Attachment) do
128			if (FCharSetID > 1) and HasDefaultCharSet then
129			begin
130			FCharSetID := CharSetID;
131			FCodePage := CodePage;
132			end
133			else
134			begin
135			FCodePage := CP_NONE;
136	tony	60	FAttachment.CharSetID2CodePage(FCharSetID,FCodePage);
137	tony	309	FAttachment.CharSetWidth(FCharSetID,FCharSetWidth);
138	tony	45	end;
139			end;
140			end;
141			end;
142	tony	47	if (FArrayDesc.array_desc_dtype in [blr_text,blr_cstring, blr_varying]) and
143			(FCharSetID = 0) then {This really shouldn't be necessary - but it is :(}
144			with aAttachment as TFBAttachment do
145			begin
146	tony	60	if HasDefaultCharSet and FAttachment.CharSetWidth(CharSetID,CharWidth) then
147	tony	56	FArrayDesc.array_desc_length := FArrayDesc.array_desc_length * CharWidth;
148	tony	47	end;
149	tony	45	end;
150
151			function TFB25ArrayMetaData.GetCharSetID: cardinal;
152			begin
153			Result := FCharSetID;
154			end;
155
156			function TFB25ArrayMetaData.GetCodePage: TSystemCodePage;
157			begin
158			Result := FCodePage;
159			end;
160
161	tony	309	function TFB25ArrayMetaData.GetCharSetWidth: integer;
162			begin
163			Result := FCharSetWidth;
164			end;
165
166	tony	45	{ TFB25Array }
167
168			procedure TFB25Array.InternalGetSlice;
169			begin
170	tony	263	with FFirebird25ClientAPI do
171	tony	45	Call(isc_array_get_slice(StatusVector,@(FDBHandle),@(FTRHandle),
172			@FArrayID, GetArrayDesc,
173			Pointer(FBuffer), @FBufSize));
174			end;
175
176			procedure TFB25Array.InternalPutSlice(Force: boolean);
177			begin
178	tony	263	with FFirebird25ClientAPI do
179	tony	45	if (isc_array_put_slice(StatusVector, @(FDBHandle),@(FTRHandle),
180			@FArrayID, GetArrayDesc,
181			Pointer(FBuffer),@FBufSize) > 0) and not Force then
182			IBDatabaseError;
183			SignalActivity;
184			end;
185
186			constructor TFB25Array.Create(aAttachment: TFB25Attachment;
187			aTransaction: TFB25Transaction; aField: IArrayMetaData);
188			begin
189			inherited Create(aAttachment,aTransaction,aField);
190			FDBHandle := aAttachment.Handle;
191			FTRHandle := aTransaction.Handle;
192	tony	263	FFirebird25ClientAPI := aAttachment.Firebird25ClientAPI;
193			OnDatabaseError := FFirebird25ClientAPI.IBDataBaseError;
194	tony	45	end;
195
196			constructor TFB25Array.Create(aAttachment: TFB25Attachment;
197			aTransaction: TFB25Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD);
198			begin
199			inherited Create(aAttachment,aTransaction,aField,ArrayID);
200			FDBHandle := aAttachment.Handle;
201			FTRHandle := aTransaction.Handle;
202	tony	263	FFirebird25ClientAPI := aAttachment.Firebird25ClientAPI;
203			OnDatabaseError := FFirebird25ClientAPI.IBDataBaseError;
204	tony	45	end;
205
206			end.
207