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
    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 FBAttachment, 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;
  CharWidth: integer;
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;
  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 FirebirdClientAPI.CharSetWidth(CharSetID,CharWidth) then
      FArrayDesc.array_desc_length *= CharWidth;
  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:	47
Committed:	Mon Jan 9 15:31:51 2017 UTC (7 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	5546 byte(s)
Log Message:	Committing updates for Release R2-0-1
#	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
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			FCodePage: TSystemCodePage;
48			protected
49			procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
50			relationName, columnName: string); override;
51			public
52			function GetCharSetID: cardinal; override;
53			function GetCodePage: TSystemCodePage; override;
54			end;
55
56			{ TFB25Array }
57
58			TFB25Array = class(TFBArray,IArray)
59			private
60			FDBHandle: TISC_DB_HANDLE;
61			FTRHandle: TISC_TR_HANDLE;
62			protected
63			procedure InternalGetSlice; override;
64			procedure InternalPutSlice(Force: boolean); override;
65			public
66			constructor Create(aAttachment: TFB25Attachment; aTransaction: TFB25Transaction; aField: IArrayMetaData); overload;
67			constructor Create(aAttachment: TFB25Attachment; aTransaction: TFB25Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD); overload;
68			end;
69
70			implementation
71
72	tony	47	uses FBAttachment, FB25ClientAPI;
73	tony	45
74			const
75			sGetArrayMetaData = 'Select F.RDB$CHARACTER_SET_ID '+
76			'From RDB$FIELDS F JOIN RDB$RELATION_FIELDS RF '+
77			'On F.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE '+
78			'Where RF.RDB$RELATION_NAME = ? and RF.RDB$FIELD_NAME = ?';
79
80			{ TFB25ArrayMetaData }
81
82			procedure TFB25ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
83			aTransaction: ITransaction; relationName, columnName: string);
84			var
85			DBHandle: TISC_DB_HANDLE;
86			TRHandle: TISC_TR_HANDLE;
87			stmt: IStatement;
88	tony	47	CharWidth: integer;
89	tony	45	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	tony	47	if (FArrayDesc.array_desc_dtype in [blr_text,blr_cstring, blr_varying]) and
124			(FCharSetID = 0) then {This really shouldn't be necessary - but it is :(}
125			with aAttachment as TFBAttachment do
126			begin
127			if HasDefaultCharSet and FirebirdClientAPI.CharSetWidth(CharSetID,CharWidth) then
128			FArrayDesc.array_desc_length *= CharWidth;
129			end;
130	tony	45	end;
131
132			function TFB25ArrayMetaData.GetCharSetID: cardinal;
133			begin
134			Result := FCharSetID;
135			end;
136
137			function TFB25ArrayMetaData.GetCodePage: TSystemCodePage;
138			begin
139			Result := FCodePage;
140			end;
141
142			{ TFB25Array }
143
144			procedure TFB25Array.InternalGetSlice;
145			begin
146			with Firebird25ClientAPI do
147			Call(isc_array_get_slice(StatusVector,@(FDBHandle),@(FTRHandle),
148			@FArrayID, GetArrayDesc,
149			Pointer(FBuffer), @FBufSize));
150			end;
151
152			procedure TFB25Array.InternalPutSlice(Force: boolean);
153			begin
154			with Firebird25ClientAPI do
155			if (isc_array_put_slice(StatusVector, @(FDBHandle),@(FTRHandle),
156			@FArrayID, GetArrayDesc,
157			Pointer(FBuffer),@FBufSize) > 0) and not Force then
158			IBDatabaseError;
159			SignalActivity;
160			end;
161
162			constructor TFB25Array.Create(aAttachment: TFB25Attachment;
163			aTransaction: TFB25Transaction; aField: IArrayMetaData);
164			begin
165			inherited Create(aAttachment,aTransaction,aField);
166			FDBHandle := aAttachment.Handle;
167			FTRHandle := aTransaction.Handle;
168			end;
169
170			constructor TFB25Array.Create(aAttachment: TFB25Attachment;
171			aTransaction: TFB25Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD);
172			begin
173			inherited Create(aAttachment,aTransaction,aField,ArrayID);
174			FDBHandle := aAttachment.Handle;
175			FTRHandle := aTransaction.Handle;
176			end;
177
178			end.
179