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: 113
Committed: Thu Jan 18 14:37:59 2018 UTC (2 years, 9 months ago) by tony
File size: 6123 byte(s)
Log Message:
Fixes Merged
Line User Rev File contents
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     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 tony 56 relationName, columnName: AnsiString); override;
54 tony 45 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 tony 47 uses FBAttachment, FB25ClientAPI;
76 tony 45
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 tony 113 'Where RF.RDB$RELATION_NAME = ? and RF.RDB$FIELD_NAME = ? '+
82     'UNION '+
83     'Select F.RDB$CHARACTER_SET_ID '+
84     'From RDB$FIELDS F JOIN RDB$PROCEDURE_PARAMETERS PP '+
85     'On F.RDB$FIELD_NAME = PP.RDB$FIELD_SOURCE '+
86     'Where PP.RDB$PROCEDURE_NAME = ? and PP.RDB$PARAMETER_NAME = ?';
87 tony 45
88     { TFB25ArrayMetaData }
89    
90     procedure TFB25ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
91 tony 56 aTransaction: ITransaction; relationName, columnName: AnsiString);
92 tony 45 var
93     DBHandle: TISC_DB_HANDLE;
94     TRHandle: TISC_TR_HANDLE;
95     stmt: IStatement;
96 tony 47 CharWidth: integer;
97 tony 56 RelName: AnsiString;
98     ColName: AnsiString;
99 tony 45 begin
100     DBHandle := (aAttachment as TFB25Attachment).Handle;
101     TRHandle := (aTransaction as TFB25Transaction).Handle;
102 tony 56 RelName := AnsiUpperCase(relationName);
103     ColName := AnsiUpperCase(columnName);
104 tony 45 with Firebird25ClientAPI do
105     if isc_array_lookup_bounds(StatusVector,@(DBHandle),@(TRHandle),
106 tony 56 PAnsiChar(RelName),PAnsiChar(ColName),@FArrayDesc) > 0 then
107 tony 45 IBDatabaseError;
108    
109     if (GetSQLType = SQL_TEXT) or (GetSQLType = SQL_VARYING) then
110     begin
111     stmt := TFB25Statement.Create(aAttachment as TFB25Attachment,aTransaction,
112     sGetArrayMetaData ,aAttachment.GetSQLDialect);
113     with stmt do
114     begin
115     SQLParams[0].AsString := RelationName;
116     SQLParams[1].AsString := ColumnName;
117 tony 113 SQLParams[2].AsString := RelationName;
118     SQLParams[3].AsString := ColumnName;
119 tony 45 with OpenCursor do
120     if FetchNext then
121     begin
122     FCharSetID := Data[0].AsInteger;
123     with (aAttachment as TFB25Attachment) do
124     if (FCharSetID > 1) and HasDefaultCharSet then
125     begin
126     FCharSetID := CharSetID;
127     FCodePage := CodePage;
128     end
129     else
130     begin
131     FCodePage := CP_NONE;
132 tony 60 FAttachment.CharSetID2CodePage(FCharSetID,FCodePage);
133 tony 45 end;
134     end;
135     end;
136     end;
137 tony 47 if (FArrayDesc.array_desc_dtype in [blr_text,blr_cstring, blr_varying]) and
138     (FCharSetID = 0) then {This really shouldn't be necessary - but it is :(}
139     with aAttachment as TFBAttachment do
140     begin
141 tony 60 if HasDefaultCharSet and FAttachment.CharSetWidth(CharSetID,CharWidth) then
142 tony 56 FArrayDesc.array_desc_length := FArrayDesc.array_desc_length * CharWidth;
143 tony 47 end;
144 tony 45 end;
145    
146     function TFB25ArrayMetaData.GetCharSetID: cardinal;
147     begin
148     Result := FCharSetID;
149     end;
150    
151     function TFB25ArrayMetaData.GetCodePage: TSystemCodePage;
152     begin
153     Result := FCodePage;
154     end;
155    
156     { TFB25Array }
157    
158     procedure TFB25Array.InternalGetSlice;
159     begin
160     with Firebird25ClientAPI do
161     Call(isc_array_get_slice(StatusVector,@(FDBHandle),@(FTRHandle),
162     @FArrayID, GetArrayDesc,
163     Pointer(FBuffer), @FBufSize));
164     end;
165    
166     procedure TFB25Array.InternalPutSlice(Force: boolean);
167     begin
168     with Firebird25ClientAPI do
169     if (isc_array_put_slice(StatusVector, @(FDBHandle),@(FTRHandle),
170     @FArrayID, GetArrayDesc,
171     Pointer(FBuffer),@FBufSize) > 0) and not Force then
172     IBDatabaseError;
173     SignalActivity;
174     end;
175    
176     constructor TFB25Array.Create(aAttachment: TFB25Attachment;
177     aTransaction: TFB25Transaction; aField: IArrayMetaData);
178     begin
179     inherited Create(aAttachment,aTransaction,aField);
180     FDBHandle := aAttachment.Handle;
181     FTRHandle := aTransaction.Handle;
182     end;
183    
184     constructor TFB25Array.Create(aAttachment: TFB25Attachment;
185     aTransaction: TFB25Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD);
186     begin
187     inherited Create(aAttachment,aTransaction,aField,ArrayID);
188     FDBHandle := aAttachment.Handle;
189     FTRHandle := aTransaction.Handle;
190     end;
191    
192     end.
193