ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/2.5/FB25Array.pas
Revision: 56
Committed: Mon Mar 6 10:20:02 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
File size: 5726 byte(s)
Log Message:
Committing updates for Trunk

File Contents

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