ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBArray.pas
(Generate patch)

Comparing ibx/trunk/fbintf/client/FBArray.pas (file contents):
Revision 45 by tony, Tue Dec 6 10:33:46 2016 UTC vs.
Revision 291 by tony, Fri Apr 17 10:26:08 2020 UTC

# Line 25 | Line 25
25   *
26   *)
27   unit FBArray;
28 + {$IFDEF MSWINDOWS}
29 + {$DEFINE WINDOWS}
30 + {$ENDIF}
31  
32   {$IFDEF FPC}
33 < {$mode objfpc}{$H+}
33 > {$mode delphi}
34   {$codepage UTF8}
35   {$interfaces COM}
36   {$ENDIF}
# Line 69 | Line 72 | type
72  
73    TFBArrayElement = class(TSQLDataItem)
74    private
75 <   FBufPtr: PChar;
75 >   FBufPtr: PByte;
76     FArray: TFBArray;
77    protected
78     function GetSQLDialect: integer; override;
79     procedure Changing; override;
80     procedure Changed; override;
81 <   function SQLData: PChar; override;
81 >   function SQLData: PByte; override;
82     function GetDataLength: cardinal; override;
83     function GetCodePage: TSystemCodePage; override;
84 +   function getCharSetID: cardinal; override;
85     procedure SetDataLength(len: cardinal); override;
86     procedure SetSQLType(aValue: cardinal); override;
87    public
88 <   constructor Create(anArray: TFBArray; P: PChar);
88 >   constructor Create(anArray: TFBArray; P: PByte);
89     function GetSQLType: cardinal; override;
90 <   function GetName: string; override;
90 >   function GetName: AnsiString; override;
91     function GetScale: integer; override;
92     function GetSize: integer;
93 <   function GetAsString: string; override;
93 >   function GetAsString: AnsiString; override;
94     procedure SetAsLong(Value: Long); override;
95     procedure SetAsShort(Value: Short); override;
96     procedure SetAsInt64(Value: Int64); override;
97 <   procedure SetAsString(Value: String); override;
97 >   procedure SetAsString(Value: AnsiString); override;
98     procedure SetAsDouble(Value: Double); override;
99     procedure SetAsFloat(Value: Float); override;
100     procedure SetAsCurrency(Value: Currency); override;
# Line 99 | Line 103 | type
103    { TFBArrayMetaData }
104  
105    TFBArrayMetaData = class(TFBInterfacedObject,IArrayMetaData)
106 +  private
107 +   function GetDType(SQLType: cardinal): UChar;
108    protected
109     FArrayDesc: TISC_ARRAY_DESC;
110 +   FCharSetID: integer;
111 +   FAttachment: IAttachment;
112     procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
113 <               relationName, columnName: string); virtual; abstract;
113 >               relationName, columnName: AnsiString); virtual; abstract;
114     function NumOfElements: integer;
115    public
116     constructor Create(aAttachment: IAttachment; aTransaction: ITransaction;
117 <     relationName, columnName: string);
117 >     relationName, columnName: AnsiString); overload;
118 >   constructor Create(aAttachment: IAttachment;SQLType: cardinal; tableName: AnsiString; columnName: AnsiString;
119 >     Scale: integer; size: cardinal; charSetID: cardinal;
120 >     dimensions: cardinal; bounds: TArrayBounds); overload;
121     function GetCodePage: TSystemCodePage; virtual; abstract;
122  
123    public
124     {IArrayMetaData}
125     function GetSQLType: cardinal;
126 <   function GetSQLTypeName: string;
126 >   function GetSQLTypeName: AnsiString;
127     function GetScale: integer;
128     function GetSize: cardinal;
129     function GetCharSetID: cardinal; virtual; abstract;
130 <   function GetTableName: string;
131 <   function GetColumnName: string;
130 >   function GetTableName: AnsiString;
131 >   function GetColumnName: AnsiString;
132     function GetDimensions: integer;
133     function GetBounds: TArrayBounds;
134    end;
# Line 127 | Line 138 | type
138  
139    TFBArray = class(TActivityReporter,IArray)
140    private
141 +    FFirebirdClientAPI: TFBClientAPI;
142      FMetaData: IArrayMetaData;
143      FIsNew: boolean;
144      FLoaded: boolean;
# Line 142 | Line 154 | type
154      FEventHandlers: array of TArrayEventHandler;
155      procedure GetArraySlice;
156      procedure PutArraySlice(Force: boolean=false);
157 <    function GetOffset(index: array of integer): PChar;
157 >    function GetOffset(index: array of integer): PByte;
158      function GetDataLength: short;
159    protected
160 <    FBuffer: PChar;
160 >    FBuffer: PByte;
161      FBufSize: ISC_LONG;
162      FArrayID: TISC_QUAD;
163      procedure AllocateBuffer; virtual;
164 <    procedure Changing;
165 <    procedure Changed;
164 >    procedure Changing; virtual;
165 >    procedure Changed;  virtual;
166      function GetArrayDesc: PISC_ARRAY_DESC;
167      procedure InternalGetSlice; virtual; abstract;
168      procedure InternalPutSlice(Force: boolean); virtual; abstract;
# Line 166 | Line 178 | type
178     public
179      {IArrayMetaData}
180      function GetSQLType: cardinal;
181 <    function GetSQLTypeName: string;
181 >    function GetSQLTypeName: AnsiString;
182      function GetScale: integer;
183      function GetSize: cardinal;
184      function GetCharSetID: cardinal;
185 <    function GetTableName: string;
186 <    function GetColumnName: string;
185 >    function GetTableName: AnsiString;
186 >    function GetColumnName: AnsiString;
187      function GetDimensions: integer;
188      function GetBounds: TArrayBounds;
189      {IArray}
# Line 190 | Line 202 | type
202      function GetAsFloat(index: array of integer): Float;
203      function GetAsLong(index: array of integer): Long;
204      function GetAsShort(index: array of integer): Short;
205 <    function GetAsString(index: array of integer): String;
205 >    function GetAsString(index: array of integer): AnsiString;
206      function GetAsVariant(index: array of integer): Variant;
207      procedure SetAsInteger(index: array of integer; AValue: integer);
208      procedure SetAsBoolean(index: array of integer; AValue: boolean);
# Line 203 | Line 215 | type
215      procedure SetAsDouble(index: array of integer; Value: Double);
216      procedure SetAsFloat(index: array of integer; Value: Float);
217      procedure SetAsShort(index: array of integer; Value: Short);
218 <    procedure SetAsString(index: array of integer; Value: String);
218 >    procedure SetAsString(index: array of integer; Value: AnsiString);
219      procedure SetAsVariant(index: array of integer; Value: Variant);
220      procedure SetBounds(dim, UpperBound, LowerBound: integer);
221      function GetAttachment: IAttachment;
# Line 235 | Line 247 | begin
247    FArray.Changed;
248   end;
249  
250 < function TFBArrayElement.SQLData: PChar;
250 > function TFBArrayElement.SQLData: PByte;
251   begin
252    Result := FBufPtr;
253   end;
# Line 250 | Line 262 | begin
262    Result := (FArray.FMetaData as TFBArrayMetaData).GetCodePage;
263   end;
264  
265 + function TFBArrayElement.getCharSetID: cardinal;
266 + begin
267 +  Result := (FArray.FMetaData as TFBArrayMetaData).GetCharSetID;
268 + end;
269 +
270   procedure TFBArrayElement.SetDataLength(len: cardinal);
271   begin
272    if len > GetDataLength then
273      IBError(ibxeArrayElementOverFlow,[nil]);
274   end;
275  
276 < constructor TFBArrayElement.Create(anArray: TFBArray; P: PChar);
276 > constructor TFBArrayElement.Create(anArray: TFBArray; P: PByte);
277   begin
278 <  inherited Create;
278 >  inherited Create(anArray.FFirebirdClientAPI);
279    FArray := anArray;
280    FBufPtr := P;
281   end;
# Line 268 | Line 285 | begin
285    Result :=  FArray.FMetaData.GetSQLType;
286   end;
287  
288 < function TFBArrayElement.GetName: string;
288 > function TFBArrayElement.GetName: AnsiString;
289   begin
290    Result := FArray.FMetaData.GetColumnName;
291   end;
# Line 283 | Line 300 | begin
300    Result := GetDataLength;
301   end;
302  
303 < function TFBArrayElement.GetAsString: string;
303 > function TFBArrayElement.GetAsString: AnsiString;
304   var rs: RawByteString;
305   begin
306    case GetSQLType of
307    SQL_VARYING:
308      begin
309 <      rs := strpas(FBufPtr);
309 >      rs := strpas(PAnsiChar(FBufPtr));
310        SetCodePage(rs,GetCodePage,false);
311        Result := rs;
312      end;
313    SQL_TEXT:
314      begin
315 <      SetString(rs,FBufPtr,GetDataLength);
315 >      SetString(rs,PAnsiChar(FBufPtr),GetDataLength);
316        SetCodePage(rs,GetCodePage,false);
317        Result := rs;
318      end
# Line 337 | Line 354 | begin
354    Changed;
355   end;
356  
357 < procedure TFBArrayElement.SetAsString(Value: String);
357 > procedure TFBArrayElement.SetAsString(Value: AnsiString);
358   var len: integer;
359      ElementSize: integer;
360   begin
361    CheckActive;
362    case GetSQLType of
363    SQL_BOOLEAN:
364 <    if CompareText(Value,STrue) = 0 then
364 >    if AnsiCompareText(Value,STrue) = 0 then
365        AsBoolean := true
366      else
367 <    if CompareText(Value,SFalse) = 0 then
367 >    if AnsiCompareText(Value,SFalse) = 0 then
368        AsBoolean := false
369      else
370        IBError(ibxeInvalidDataConversion,[nil]);
# Line 362 | Line 379 | begin
379        if Len > 0 then
380          Move(Value[1],FBufPtr^,len);
381        if Len < ElementSize - 2 then
382 <        (FBufPtr+len)^ := #0;
382 >        (FBufPtr+len)^ := 0;
383        Changed;
384      end;
385  
# Line 383 | Line 400 | begin
400      if trim(Value) = '' then
401        SetAsInt64(0)
402      else
403 <      SetAsInt64(StrToInt(Value));
403 >      SetAsInt64(AdjustScaleFromCurrency(StrToCurr(Value),GetScale));
404  
405    SQL_D_FLOAT,
406    SQL_DOUBLE,
# Line 468 | Line 485 | end;
485   {TFBArrayMetaData}
486  
487   constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
488 <  aTransaction: ITransaction; relationName, columnName: string);
488 >  aTransaction: ITransaction; relationName, columnName: AnsiString);
489   begin
490    inherited Create;
491 +  FAttachment := aAttachment;
492    LoadMetaData(aAttachment,aTransaction,relationName, columnName);
493   end;
494  
495 + constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
496 +  SQLType: cardinal; tableName: AnsiString; columnName: AnsiString;
497 +  Scale: integer; size: cardinal; charSetID: cardinal; dimensions: cardinal;
498 +  bounds: TArrayBounds);
499 + var i: integer;
500 + begin
501 +  inherited Create;
502 +  FAttachment := aAttachment;
503 +  with FArrayDesc do
504 +  begin
505 +    array_desc_dtype := GetDType(SQLType);
506 +    array_desc_scale := Scale;
507 +    array_desc_length := UShort(size);
508 +    StrPLCopy(array_desc_field_name,columnName,sizeof(array_desc_field_name));
509 +    StrPLCopy(array_desc_relation_name,tableName,sizeof(array_desc_relation_name));
510 +    array_desc_dimensions := dimensions;
511 +    array_desc_flags := 0;
512 +    FCharSetID := charSetID;
513 +    for i := 0 to Length(bounds) - 1 do
514 +    begin
515 +     array_desc_bounds[i].array_bound_lower := bounds[i].LowerBound;
516 +     array_desc_bounds[i].array_bound_upper := bounds[i].UpperBound;
517 +    end;
518 +  end;
519 + end;
520 +
521   function TFBArrayMetaData.GetSQLType: cardinal;
522   begin
523    case  FArrayDesc.array_desc_dtype of
# Line 504 | Line 548 | begin
548    end;
549   end;
550  
551 < function TFBArrayMetaData.GetSQLTypeName: string;
551 > function TFBArrayMetaData.GetSQLTypeName: AnsiString;
552   begin
553    Result := TSQLDataItem.GetSQLTypeName(GetSQLType);
554   end;
# Line 519 | Line 563 | begin
563    Result := FArrayDesc.array_desc_length;
564   end;
565  
566 < function TFBArrayMetaData.GetTableName: string;
566 > function TFBArrayMetaData.GetTableName: AnsiString;
567   begin
568    with FArrayDesc do
569 <   SetString(Result,PChar(@array_desc_relation_name),sizeof(array_desc_relation_name));
569 >   SetString(Result,PAnsiChar(@array_desc_relation_name),sizeof(array_desc_relation_name));
570    Result := trim(Result);
571   end;
572  
573 < function TFBArrayMetaData.GetColumnName: string;
573 > function TFBArrayMetaData.GetColumnName: AnsiString;
574   begin
575    with FArrayDesc do
576 <    SetString(Result,PChar(@FArrayDesc.array_desc_field_name),sizeof(array_desc_field_name));
576 >    SetString(Result,PAnsiChar(@FArrayDesc.array_desc_field_name),sizeof(array_desc_field_name));
577    Result := trim(Result);
578   end;
579  
# Line 549 | Line 593 | begin
593    end;
594   end;
595  
596 + function TFBArrayMetaData.GetDType(SQLType: cardinal): UChar;
597 + begin
598 +  case  SQLType of
599 +  SQL_TEXT:
600 +    Result := blr_text;
601 +  SQL_SHORT:
602 +    Result :=  blr_short;
603 +  SQL_LONG:
604 +    Result := blr_long;
605 +  SQL_QUAD:
606 +    Result := blr_quad;
607 +  SQL_FLOAT:
608 +    Result := blr_float;
609 +  SQL_D_FLOAT:
610 +    Result := blr_double;
611 +  SQL_TIMESTAMP:
612 +    Result := blr_timestamp;
613 +  SQL_VARYING:
614 +    Result := blr_varying;
615 +  SQL_TYPE_DATE:
616 +    Result := blr_sql_date;
617 +  SQL_TYPE_TIME:
618 +    Result :=  blr_sql_time;
619 +  SQL_INT64:
620 +    Result := blr_int64;
621 +  end;
622 + end;
623 +
624   function TFBArrayMetaData.NumOfElements: integer;
625   var i: integer;
626      Bounds: TArrayBounds;
# Line 556 | Line 628 | begin
628    Result := 1;
629    Bounds := GetBounds;
630    for i := 0 to Length(Bounds) - 1 do
631 <    Result *= (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
631 >    Result := Result * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
632   end;
633  
634  
# Line 579 | Line 651 | begin
651      FElementSize := FArrayDesc.array_desc_length;
652      case GetSQLType of
653      SQL_VARYING:
654 <      FElementSize += 2;
654 >      FElementSize := FElementSize + 2;
655      SQL_TEXT:
656 <      FElementSize += 1;
656 >      FElementSize := FElementSize + 1;
657      end;
658      FBufSize := FElementSize * l;
659  
660 <    with FirebirdClientAPI do
660 >    with FFirebirdClientAPI do
661        IBAlloc(FBuffer,0,FBufSize);
662  
663      Dims := GetDimensions;
# Line 639 | Line 711 | begin
711    FIsNew := false;
712   end;
713  
714 < function TFBArray.GetOffset(index: array of integer): PChar;
714 > function TFBArray.GetOffset(index: array of integer): PByte;
715   var i: integer;
716      Bounds: TArrayBounds;
717      FlatIndex: integer;
# Line 654 | Line 726 | begin
726      if (index[i] < Bounds[i].LowerBound) or (index[i] > Bounds[i].UpperBound) then
727        IBError(ibxeInvalidSubscript,[index[i],i]);
728  
729 <    FlatIndex += FOffsets[i]*(index[i] - Bounds[i].LowerBound);
729 >    FlatIndex := FlatIndex + FOffsets[i]*(index[i] - Bounds[i].LowerBound);
730    end;
731    Result := FBuffer + FlatIndex*FElementSize;
732   end;
# Line 674 | Line 746 | begin
746    inherited Create(aTransaction);
747    FMetaData := aField;
748    FAttachment := aAttachment;
749 +  FFirebirdClientAPI := aTransaction.FirebirdAPI;
750    FTransactionIntf :=  aTransaction;
751    FTransactionSeqNo := aTransaction.TransactionSeqNo;
752    FIsNew := true;
# Line 692 | Line 765 | begin
765    FMetaData := aField;
766    FArrayID := ArrayID;
767    FAttachment := aAttachment;
768 +  FFirebirdClientAPI := aTransaction.FirebirdAPI;
769    FTransactionIntf :=  aTransaction;
770    FTransactionSeqNo := aTransaction.TransactionSeqNo;
771    FIsNew := false;
# Line 762 | Line 836 | begin
836    Result := FMetaData.GetSQLType;
837   end;
838  
839 < function TFBArray.GetSQLTypeName: string;
839 > function TFBArray.GetSQLTypeName: AnsiString;
840   begin
841    Result := FMetaData.GetSQLTypeName;
842   end;
# Line 782 | Line 856 | begin
856    Result := FMetaData.GetCharSetID;
857   end;
858  
859 < function TFBArray.GetTableName: string;
859 > function TFBArray.GetTableName: AnsiString;
860   begin
861    Result := FMetaData.GetTableName;
862   end;
863  
864 < function TFBArray.GetColumnName: string;
864 > function TFBArray.GetColumnName: AnsiString;
865   begin
866    Result := FMetaData.GetColumnName;
867   end;
# Line 865 | Line 939 | begin
939    Result := FElement.GetAsShort;
940   end;
941  
942 < function TFBArray.GetAsString(index: array of integer): String;
942 > function TFBArray.GetAsString(index: array of integer): AnsiString;
943   begin
944    GetArraySlice;
945    FElement.FBufPtr := GetOffset(index);
# Line 945 | Line 1019 | begin
1019    FElement.SetAsShort(Value);
1020   end;
1021  
1022 < procedure TFBArray.SetAsString(index: array of integer; Value: String);
1022 > procedure TFBArray.SetAsString(index: array of integer; Value: AnsiString);
1023   begin
1024    FElement.FBufPtr := GetOffset(index);
1025    FElement.SetAsString(Value);
# Line 998 | Line 1072 | procedure TFBArray.RemoveEventHandler(Ha
1072   var i,j : integer;
1073   begin
1074    for i := Length(FEventHandlers) - 1 downto 0 do
1075 <    if FEventHandlers[i] = Handler then
1075 >    if (TMethod(FEventHandlers[i]).Code = TMethod(Handler).Code) and
1076 >      (TMethod(FEventHandlers[i]).Data = TMethod(Handler).Data) then
1077      begin
1078        for j := i to Length(FEventHandlers) - 2 do
1079          FEventHandlers[i] := FEventHandlers[i+1];

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines