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 FPC}
{$mode objfpc}{$H+}
{$codepage UTF8}
{$interfaces COM}
{$ENDIF}

interface

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

type

  { TFB25ArrayMetaData }

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

  { TFB25Array }

  TFB25Array = class(TFBArray,IArray)
  private
    FDBHandle: TISC_DB_HANDLE;
    FTRHandle: TISC_TR_HANDLE;
  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 FB25ClientAPI;

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 = ?';

  { TFB25ArrayMetaData }

procedure TFB25ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
  aTransaction: ITransaction; relationName, columnName: string);
var
  DBHandle: TISC_DB_HANDLE;
  TRHandle: TISC_TR_HANDLE;
  stmt: IStatement;
begin
  DBHandle := (aAttachment as TFB25Attachment).Handle;
  TRHandle := (aTransaction as TFB25Transaction).Handle;
  with Firebird25ClientAPI do
    if isc_array_lookup_bounds(StatusVector,@(DBHandle),@(TRHandle),
        PChar(AnsiUpperCase(relationName)),PChar(AnsiUpperCase(columnName)),@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;
      with OpenCursor do
      if FetchNext then
      begin
        FCharSetID := Data[0].AsInteger;
        with (aAttachment as TFB25Attachment) do
        if (FCharSetID > 1) and HasDefaultCharSet then
        begin
          FCharSetID := CharSetID;
          FCodePage := CodePage;
        end
        else
        begin
          FCodePage := CP_NONE;
          FirebirdClientAPI.CharSetID2CodePage(FCharSetID,FCodePage);
        end;
      end;
    end;
  end;
end;

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

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

{ TFB25Array }

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

procedure TFB25Array.InternalPutSlice(Force: boolean);
begin
  with Firebird25ClientAPI 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;
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;
end;

end.

Revision:	45
Committed:	Tue Dec 6 10:33:46 2016 UTC (7 years, 11 months ago) by tony
Content type:	text/x-pascal
File size:	5187 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	Content
1	(*
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
29	{$IFDEF FPC}
30	{$mode objfpc}{$H+}
31	{$codepage UTF8}
32	{$interfaces COM}
33	{$ENDIF}
34
35	interface
36
37	uses
38	Classes, SysUtils, IB, FBArray, IBHeader, FB25Statement, FB25Attachment, FBClientAPI,
39	FB25Transaction;
40
41	type
42
43	{ TFB25ArrayMetaData }
44
45	TFB25ArrayMetaData = class(TFBArrayMetaData,IArrayMetaData)
46	private
47	FCharSetID: integer;
48	FCodePage: TSystemCodePage;
49	protected
50	procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
51	relationName, columnName: string); override;
52	public
53	function GetCharSetID: cardinal; override;
54	function GetCodePage: TSystemCodePage; override;
55	end;
56
57	{ TFB25Array }
58
59	TFB25Array = class(TFBArray,IArray)
60	private
61	FDBHandle: TISC_DB_HANDLE;
62	FTRHandle: TISC_TR_HANDLE;
63	protected
64	procedure InternalGetSlice; override;
65	procedure InternalPutSlice(Force: boolean); override;
66	public
67	constructor Create(aAttachment: TFB25Attachment; aTransaction: TFB25Transaction; aField: IArrayMetaData); overload;
68	constructor Create(aAttachment: TFB25Attachment; aTransaction: TFB25Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD); overload;
69	end;
70
71	implementation
72
73	uses FB25ClientAPI;
74
75	const
76	sGetArrayMetaData = 'Select F.RDB$CHARACTER_SET_ID '+
77	'From RDB$FIELDS F JOIN RDB$RELATION_FIELDS RF '+
78	'On F.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE '+
79	'Where RF.RDB$RELATION_NAME = ? and RF.RDB$FIELD_NAME = ?';
80
81	{ TFB25ArrayMetaData }
82
83	procedure TFB25ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
84	aTransaction: ITransaction; relationName, columnName: string);
85	var
86	DBHandle: TISC_DB_HANDLE;
87	TRHandle: TISC_TR_HANDLE;
88	stmt: IStatement;
89	begin
90	DBHandle := (aAttachment as TFB25Attachment).Handle;
91	TRHandle := (aTransaction as TFB25Transaction).Handle;
92	with Firebird25ClientAPI do
93	if isc_array_lookup_bounds(StatusVector,@(DBHandle),@(TRHandle),
94	PChar(AnsiUpperCase(relationName)),PChar(AnsiUpperCase(columnName)),@FArrayDesc) > 0 then
95	IBDatabaseError;
96
97	if (GetSQLType = SQL_TEXT) or (GetSQLType = SQL_VARYING) then
98	begin
99	stmt := TFB25Statement.Create(aAttachment as TFB25Attachment,aTransaction,
100	sGetArrayMetaData ,aAttachment.GetSQLDialect);
101	with stmt do
102	begin
103	SQLParams[0].AsString := RelationName;
104	SQLParams[1].AsString := ColumnName;
105	with OpenCursor do
106	if FetchNext then
107	begin
108	FCharSetID := Data[0].AsInteger;
109	with (aAttachment as TFB25Attachment) do
110	if (FCharSetID > 1) and HasDefaultCharSet then
111	begin
112	FCharSetID := CharSetID;
113	FCodePage := CodePage;
114	end
115	else
116	begin
117	FCodePage := CP_NONE;
118	FirebirdClientAPI.CharSetID2CodePage(FCharSetID,FCodePage);
119	end;
120	end;
121	end;
122	end;
123	end;
124
125	function TFB25ArrayMetaData.GetCharSetID: cardinal;
126	begin
127	Result := FCharSetID;
128	end;
129
130	function TFB25ArrayMetaData.GetCodePage: TSystemCodePage;
131	begin
132	Result := FCodePage;
133	end;
134
135	{ TFB25Array }
136
137	procedure TFB25Array.InternalGetSlice;
138	begin
139	with Firebird25ClientAPI do
140	Call(isc_array_get_slice(StatusVector,@(FDBHandle),@(FTRHandle),
141	@FArrayID, GetArrayDesc,
142	Pointer(FBuffer), @FBufSize));
143	end;
144
145	procedure TFB25Array.InternalPutSlice(Force: boolean);
146	begin
147	with Firebird25ClientAPI do
148	if (isc_array_put_slice(StatusVector, @(FDBHandle),@(FTRHandle),
149	@FArrayID, GetArrayDesc,
150	Pointer(FBuffer),@FBufSize) > 0) and not Force then
151	IBDatabaseError;
152	SignalActivity;
153	end;
154
155	constructor TFB25Array.Create(aAttachment: TFB25Attachment;
156	aTransaction: TFB25Transaction; aField: IArrayMetaData);
157	begin
158	inherited Create(aAttachment,aTransaction,aField);
159	FDBHandle := aAttachment.Handle;
160	FTRHandle := aTransaction.Handle;
161	end;
162
163	constructor TFB25Array.Create(aAttachment: TFB25Attachment;
164	aTransaction: TFB25Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD);
165	begin
166	inherited Create(aAttachment,aTransaction,aField,ArrayID);
167	FDBHandle := aAttachment.Handle;
168	FTRHandle := aTransaction.Handle;
169	end;
170
171	end.
172