ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/fbintf/client/FBArray.pas

Comparing ibx/trunk/fbintf/client/FBArray.pas (file contents):
Revision 45 by tony, Tue Dec 6 10:33:46 2016 UTC vs.
Revision 309 by tony, Tue Jul 21 08:00:42 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 GetCharSetWidth: integer; override;
94	>	function GetAsString: AnsiString; override;
95		procedure SetAsLong(Value: Long); override;
96		procedure SetAsShort(Value: Short); override;
97		procedure SetAsInt64(Value: Int64); override;
98	<	procedure SetAsString(Value: String); override;
98	>	procedure SetAsString(Value: AnsiString); override;
99		procedure SetAsDouble(Value: Double); override;
100		procedure SetAsFloat(Value: Float); override;
101		procedure SetAsCurrency(Value: Currency); override;
#	Line 99 | Line 104 | type
104		{ TFBArrayMetaData }
105
106		TFBArrayMetaData = class(TFBInterfacedObject,IArrayMetaData)
107	+	private
108	+	function GetDType(SQLType: cardinal): UChar;
109		protected
110		FArrayDesc: TISC_ARRAY_DESC;
111	+	FCharSetID: integer;
112	+	FAttachment: IAttachment;
113		procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
114	<	relationName, columnName: string); virtual; abstract;
114	>	relationName, columnName: AnsiString); virtual; abstract;
115		function NumOfElements: integer;
116		public
117		constructor Create(aAttachment: IAttachment; aTransaction: ITransaction;
118	<	relationName, columnName: string);
118	>	relationName, columnName: AnsiString); overload;
119	>	constructor Create(aAttachment: IAttachment;SQLType: cardinal; tableName: AnsiString; columnName: AnsiString;
120	>	Scale: integer; size: cardinal; charSetID: cardinal;
121	>	dimensions: cardinal; bounds: TArrayBounds); overload;
122		function GetCodePage: TSystemCodePage; virtual; abstract;
123
124		public
125		{IArrayMetaData}
126		function GetSQLType: cardinal;
127	<	function GetSQLTypeName: string;
127	>	function GetSQLTypeName: AnsiString;
128		function GetScale: integer;
129		function GetSize: cardinal;
130		function GetCharSetID: cardinal; virtual; abstract;
131	<	function GetTableName: string;
132	<	function GetColumnName: string;
131	>	function GetCharSetWidth: integer; virtual; abstract;
132	>	function GetTableName: AnsiString;
133	>	function GetColumnName: AnsiString;
134		function GetDimensions: integer;
135		function GetBounds: TArrayBounds;
136		end;
#	Line 127 | Line 140 | type
140
141		TFBArray = class(TActivityReporter,IArray)
142		private
143	+	FFirebirdClientAPI: TFBClientAPI;
144		FMetaData: IArrayMetaData;
145		FIsNew: boolean;
146		FLoaded: boolean;
#	Line 142 | Line 156 | type
156		FEventHandlers: array of TArrayEventHandler;
157		procedure GetArraySlice;
158		procedure PutArraySlice(Force: boolean=false);
159	<	function GetOffset(index: array of integer): PChar;
159	>	function GetOffset(index: array of integer): PByte;
160		function GetDataLength: short;
161		protected
162	<	FBuffer: PChar;
162	>	FBuffer: PByte;
163		FBufSize: ISC_LONG;
164		FArrayID: TISC_QUAD;
165		procedure AllocateBuffer; virtual;
166	<	procedure Changing;
167	<	procedure Changed;
166	>	procedure Changing; virtual;
167	>	procedure Changed;  virtual;
168		function GetArrayDesc: PISC_ARRAY_DESC;
169		procedure InternalGetSlice; virtual; abstract;
170		procedure InternalPutSlice(Force: boolean); virtual; abstract;
#	Line 166 | Line 180 | type
180		public
181		{IArrayMetaData}
182		function GetSQLType: cardinal;
183	<	function GetSQLTypeName: string;
183	>	function GetSQLTypeName: AnsiString;
184		function GetScale: integer;
185		function GetSize: cardinal;
186		function GetCharSetID: cardinal;
187	<	function GetTableName: string;
188	<	function GetColumnName: string;
187	>	function GetCharSetWidth: integer;
188	>	function GetTableName: AnsiString;
189	>	function GetColumnName: AnsiString;
190		function GetDimensions: integer;
191		function GetBounds: TArrayBounds;
192		{IArray}
#	Line 190 | Line 205 | type
205		function GetAsFloat(index: array of integer): Float;
206		function GetAsLong(index: array of integer): Long;
207		function GetAsShort(index: array of integer): Short;
208	<	function GetAsString(index: array of integer): String;
208	>	function GetAsString(index: array of integer): AnsiString;
209		function GetAsVariant(index: array of integer): Variant;
210		procedure SetAsInteger(index: array of integer; AValue: integer);
211		procedure SetAsBoolean(index: array of integer; AValue: boolean);
#	Line 203 | Line 218 | type
218		procedure SetAsDouble(index: array of integer; Value: Double);
219		procedure SetAsFloat(index: array of integer; Value: Float);
220		procedure SetAsShort(index: array of integer; Value: Short);
221	<	procedure SetAsString(index: array of integer; Value: String);
221	>	procedure SetAsString(index: array of integer; Value: AnsiString);
222		procedure SetAsVariant(index: array of integer; Value: Variant);
223		procedure SetBounds(dim, UpperBound, LowerBound: integer);
224		function GetAttachment: IAttachment;
#	Line 235 | Line 250 | begin
250		FArray.Changed;
251		end;
252
253	<	function TFBArrayElement.SQLData: PChar;
253	>	function TFBArrayElement.SQLData: PByte;
254		begin
255		Result := FBufPtr;
256		end;
#	Line 250 | Line 265 | begin
265		Result := (FArray.FMetaData as TFBArrayMetaData).GetCodePage;
266		end;
267
268	+	function TFBArrayElement.getCharSetID: cardinal;
269	+	begin
270	+	Result := (FArray.FMetaData as TFBArrayMetaData).GetCharSetID;
271	+	end;
272	+
273		procedure TFBArrayElement.SetDataLength(len: cardinal);
274		begin
275		if len > GetDataLength then
276		IBError(ibxeArrayElementOverFlow,[nil]);
277		end;
278
279	<	constructor TFBArrayElement.Create(anArray: TFBArray; P: PChar);
279	>	constructor TFBArrayElement.Create(anArray: TFBArray; P: PByte);
280		begin
281	<	inherited Create;
281	>	inherited Create(anArray.FFirebirdClientAPI);
282		FArray := anArray;
283		FBufPtr := P;
284		end;
#	Line 268 | Line 288 | begin
288		Result :=  FArray.FMetaData.GetSQLType;
289		end;
290
291	<	function TFBArrayElement.GetName: string;
291	>	function TFBArrayElement.GetName: AnsiString;
292		begin
293		Result := FArray.FMetaData.GetColumnName;
294		end;
#	Line 283 | Line 303 | begin
303		Result := GetDataLength;
304		end;
305
306	<	function TFBArrayElement.GetAsString: string;
306	>	function TFBArrayElement.GetCharSetWidth: integer;
307	>	begin
308	>	Result := FArray.FMetaData.GetCharSetWidth;
309	>	end;
310	>
311	>	function TFBArrayElement.GetAsString: AnsiString;
312		var rs: RawByteString;
313		begin
314		case GetSQLType of
315		SQL_VARYING:
316		begin
317	<	rs := strpas(FBufPtr);
317	>	rs := strpas(PAnsiChar(FBufPtr));
318		SetCodePage(rs,GetCodePage,false);
319		Result := rs;
320		end;
321		SQL_TEXT:
322		begin
323	<	SetString(rs,FBufPtr,GetDataLength);
323	>	SetString(rs,PAnsiChar(FBufPtr),GetDataLength);
324		SetCodePage(rs,GetCodePage,false);
325		Result := rs;
326		end
#	Line 337 | Line 362 | begin
362		Changed;
363		end;
364
365	<	procedure TFBArrayElement.SetAsString(Value: String);
365	>	procedure TFBArrayElement.SetAsString(Value: AnsiString);
366		var len: integer;
367		ElementSize: integer;
368		begin
369		CheckActive;
370		case GetSQLType of
371		SQL_BOOLEAN:
372	<	if CompareText(Value,STrue) = 0 then
372	>	if AnsiCompareText(Value,STrue) = 0 then
373		AsBoolean := true
374		else
375	<	if CompareText(Value,SFalse) = 0 then
375	>	if AnsiCompareText(Value,SFalse) = 0 then
376		AsBoolean := false
377		else
378		IBError(ibxeInvalidDataConversion,[nil]);
#	Line 362 | Line 387 | begin
387		if Len > 0 then
388		Move(Value[1],FBufPtr^,len);
389		if Len < ElementSize - 2 then
390	<	(FBufPtr+len)^ := #0;
390	>	(FBufPtr+len)^ := 0;
391		Changed;
392		end;
393
#	Line 383 | Line 408 | begin
408		if trim(Value) = '' then
409		SetAsInt64(0)
410		else
411	<	SetAsInt64(StrToInt(Value));
411	>	SetAsInt64(AdjustScaleFromCurrency(StrToCurr(Value),GetScale));
412
413		SQL_D_FLOAT,
414		SQL_DOUBLE,
#	Line 468 | Line 493 | end;
493		{TFBArrayMetaData}
494
495		constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
496	<	aTransaction: ITransaction; relationName, columnName: string);
496	>	aTransaction: ITransaction; relationName, columnName: AnsiString);
497		begin
498		inherited Create;
499	+	FAttachment := aAttachment;
500		LoadMetaData(aAttachment,aTransaction,relationName, columnName);
501		end;
502
503	+	constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
504	+	SQLType: cardinal; tableName: AnsiString; columnName: AnsiString;
505	+	Scale: integer; size: cardinal; charSetID: cardinal; dimensions: cardinal;
506	+	bounds: TArrayBounds);
507	+	var i: integer;
508	+	begin
509	+	inherited Create;
510	+	FAttachment := aAttachment;
511	+	with FArrayDesc do
512	+	begin
513	+	array_desc_dtype := GetDType(SQLType);
514	+	array_desc_scale := Scale;
515	+	array_desc_length := UShort(size);
516	+	StrPLCopy(array_desc_field_name,columnName,sizeof(array_desc_field_name));
517	+	StrPLCopy(array_desc_relation_name,tableName,sizeof(array_desc_relation_name));
518	+	array_desc_dimensions := dimensions;
519	+	array_desc_flags := 0;
520	+	FCharSetID := charSetID;
521	+	for i := 0 to Length(bounds) - 1 do
522	+	begin
523	+	array_desc_bounds[i].array_bound_lower := bounds[i].LowerBound;
524	+	array_desc_bounds[i].array_bound_upper := bounds[i].UpperBound;
525	+	end;
526	+	end;
527	+	end;
528	+
529		function TFBArrayMetaData.GetSQLType: cardinal;
530		begin
531		case  FArrayDesc.array_desc_dtype of
#	Line 504 | Line 556 | begin
556		end;
557		end;
558
559	<	function TFBArrayMetaData.GetSQLTypeName: string;
559	>	function TFBArrayMetaData.GetSQLTypeName: AnsiString;
560		begin
561		Result := TSQLDataItem.GetSQLTypeName(GetSQLType);
562		end;
#	Line 519 | Line 571 | begin
571		Result := FArrayDesc.array_desc_length;
572		end;
573
574	<	function TFBArrayMetaData.GetTableName: string;
574	>	function TFBArrayMetaData.GetTableName: AnsiString;
575		begin
576		with FArrayDesc do
577	<	SetString(Result,PChar(@array_desc_relation_name),sizeof(array_desc_relation_name));
577	>	SetString(Result,PAnsiChar(@array_desc_relation_name),sizeof(array_desc_relation_name));
578		Result := trim(Result);
579		end;
580
581	<	function TFBArrayMetaData.GetColumnName: string;
581	>	function TFBArrayMetaData.GetColumnName: AnsiString;
582		begin
583		with FArrayDesc do
584	<	SetString(Result,PChar(@FArrayDesc.array_desc_field_name),sizeof(array_desc_field_name));
584	>	SetString(Result,PAnsiChar(@FArrayDesc.array_desc_field_name),sizeof(array_desc_field_name));
585		Result := trim(Result);
586		end;
587
#	Line 549 | Line 601 | begin
601		end;
602		end;
603
604	+	function TFBArrayMetaData.GetDType(SQLType: cardinal): UChar;
605	+	begin
606	+	case  SQLType of
607	+	SQL_TEXT:
608	+	Result := blr_text;
609	+	SQL_SHORT:
610	+	Result :=  blr_short;
611	+	SQL_LONG:
612	+	Result := blr_long;
613	+	SQL_QUAD:
614	+	Result := blr_quad;
615	+	SQL_FLOAT:
616	+	Result := blr_float;
617	+	SQL_D_FLOAT:
618	+	Result := blr_double;
619	+	SQL_TIMESTAMP:
620	+	Result := blr_timestamp;
621	+	SQL_VARYING:
622	+	Result := blr_varying;
623	+	SQL_TYPE_DATE:
624	+	Result := blr_sql_date;
625	+	SQL_TYPE_TIME:
626	+	Result :=  blr_sql_time;
627	+	SQL_INT64:
628	+	Result := blr_int64;
629	+	end;
630	+	end;
631	+
632		function TFBArrayMetaData.NumOfElements: integer;
633		var i: integer;
634		Bounds: TArrayBounds;
#	Line 556 | Line 636 | begin
636		Result := 1;
637		Bounds := GetBounds;
638		for i := 0 to Length(Bounds) - 1 do
639	<	Result *= (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
639	>	Result := Result * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
640		end;
641
642
#	Line 579 | Line 659 | begin
659		FElementSize := FArrayDesc.array_desc_length;
660		case GetSQLType of
661		SQL_VARYING:
662	<	FElementSize += 2;
662	>	FElementSize := FElementSize + 2;
663		SQL_TEXT:
664	<	FElementSize += 1;
664	>	FElementSize := FElementSize + 1;
665		end;
666		FBufSize := FElementSize * l;
667
668	<	with FirebirdClientAPI do
668	>	with FFirebirdClientAPI do
669		IBAlloc(FBuffer,0,FBufSize);
670
671		Dims := GetDimensions;
#	Line 639 | Line 719 | begin
719		FIsNew := false;
720		end;
721
722	<	function TFBArray.GetOffset(index: array of integer): PChar;
722	>	function TFBArray.GetOffset(index: array of integer): PByte;
723		var i: integer;
724		Bounds: TArrayBounds;
725		FlatIndex: integer;
#	Line 654 | Line 734 | begin
734		if (index[i] < Bounds[i].LowerBound) or (index[i] > Bounds[i].UpperBound) then
735		IBError(ibxeInvalidSubscript,[index[i],i]);
736
737	<	FlatIndex += FOffsets[i]*(index[i] - Bounds[i].LowerBound);
737	>	FlatIndex := FlatIndex + FOffsets[i]*(index[i] - Bounds[i].LowerBound);
738		end;
739		Result := FBuffer + FlatIndex*FElementSize;
740		end;
#	Line 674 | Line 754 | begin
754		inherited Create(aTransaction);
755		FMetaData := aField;
756		FAttachment := aAttachment;
757	+	FFirebirdClientAPI := aTransaction.FirebirdAPI;
758		FTransactionIntf :=  aTransaction;
759		FTransactionSeqNo := aTransaction.TransactionSeqNo;
760		FIsNew := true;
#	Line 692 | Line 773 | begin
773		FMetaData := aField;
774		FArrayID := ArrayID;
775		FAttachment := aAttachment;
776	+	FFirebirdClientAPI := aTransaction.FirebirdAPI;
777		FTransactionIntf :=  aTransaction;
778		FTransactionSeqNo := aTransaction.TransactionSeqNo;
779		FIsNew := false;
#	Line 762 | Line 844 | begin
844		Result := FMetaData.GetSQLType;
845		end;
846
847	<	function TFBArray.GetSQLTypeName: string;
847	>	function TFBArray.GetSQLTypeName: AnsiString;
848		begin
849		Result := FMetaData.GetSQLTypeName;
850		end;
#	Line 782 | Line 864 | begin
864		Result := FMetaData.GetCharSetID;
865		end;
866
867	<	function TFBArray.GetTableName: string;
867	>	function TFBArray.GetCharSetWidth: integer;
868	>	begin
869	>	Result := FMetaData.GetCharSetWidth;
870	>	end;
871	>
872	>	function TFBArray.GetTableName: AnsiString;
873		begin
874		Result := FMetaData.GetTableName;
875		end;
876
877	<	function TFBArray.GetColumnName: string;
877	>	function TFBArray.GetColumnName: AnsiString;
878		begin
879		Result := FMetaData.GetColumnName;
880		end;
#	Line 865 | Line 952 | begin
952		Result := FElement.GetAsShort;
953		end;
954
955	<	function TFBArray.GetAsString(index: array of integer): String;
955	>	function TFBArray.GetAsString(index: array of integer): AnsiString;
956		begin
957		GetArraySlice;
958		FElement.FBufPtr := GetOffset(index);
#	Line 945 | Line 1032 | begin
1032		FElement.SetAsShort(Value);
1033		end;
1034
1035	<	procedure TFBArray.SetAsString(index: array of integer; Value: String);
1035	>	procedure TFBArray.SetAsString(index: array of integer; Value: AnsiString);
1036		begin
1037		FElement.FBufPtr := GetOffset(index);
1038		FElement.SetAsString(Value);
#	Line 998 | Line 1085 | procedure TFBArray.RemoveEventHandler(Ha
1085		var i,j : integer;
1086		begin
1087		for i := Length(FEventHandlers) - 1 downto 0 do
1088	<	if FEventHandlers[i] = Handler then
1088	>	if (TMethod(FEventHandlers[i]).Code = TMethod(Handler).Code) and
1089	>	(TMethod(FEventHandlers[i]).Data = TMethod(Handler).Data) then
1090		begin
1091		for j := i to Length(FEventHandlers) - 2 do
1092		FEventHandlers[i] := FEventHandlers[i+1];

Diff Legend

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