ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/FBOutputBlock.pas
Revision: 363
Committed: Tue Dec 7 13:30:05 2021 UTC (8 months, 1 week ago) by tony
File size: 36410 byte(s)
Log Message:
add fbintf
Line File contents
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 FBOutputBlock;
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 { $DEFINE DEBUGOUTPUTBLOCK}
39
40 interface
41
42 {Provides common handling for the DB Info results, SQL Info and Service Response Block}
43
44 uses
45 Classes, SysUtils, FBClientAPI, IB, FBActivityMonitor;
46
47 const
48 DefaultBufferSize = 32000;
49 DBInfoDefaultBufferSize = DefaultBufferSize; {allow for database page}
50
51 type
52 TItemDataType = (dtString, dtString2, dtByte, dtBytes, dtInteger, dtIntegerFixed,
53 dtTinyInteger, dtShortIntFixed, dtnone, dtList, dtSpecial, dtDateTime, dtOctetString);
54
55 POutputBlockItemData = ^TOutputBlockItemData;
56 TOutputBlockItemData = record
57 {Describes a Clumplet in the buffer. FBufPtr always points to the clumplet id
58 the rest of the clumplet up to the FSize is data. The data format is
59 given by FDataType, and the data length is given by FDataLength}
60 FBufPtr: PByte;
61 FDataLength: integer;
62 FSize: integer;
63 FDataType: TItemDataType;
64 FTruncated: boolean;
65 FError: boolean;
66 FSubItems: array of POutputBlockItemData;
67 end;
68
69 { TOutputBlock }
70
71 TOutputBlock = class(TFBInterfacedObject)
72 private
73 FBuffer: PByte;
74 FBufSize: integer;
75 FBufferParsed: boolean;
76 FFirebirdClientAPI: TFBClientAPI;
77 procedure ParseBuffer;
78 {$IFDEF DEBUGOUTPUTBLOCK}
79 procedure FormattedPrint(const aItems: array of POutputBlockItemData;
80 Indent: AnsiString);
81 {$ENDIF}
82 protected
83 FIntegerType: TItemDataType;
84 FError: boolean;
85 FTruncated: boolean;
86 FItems: array of POutputBlockItemData;
87 procedure DoParseBuffer; virtual; abstract;
88 function AddItem(BufPtr: PByte): POutputBlockItemData;
89 function AddIntegerItem(BufPtr: PByte; IntType: TItemDataType): POutputBlockItemData; overload;
90 function AddIntegerItem(BufPtr: PByte): POutputBlockItemData; overload;
91 function AddStringItem(BufPtr: PByte): POutputBlockItemData;
92 function AddShortStringItem(BufPtr: PByte): POutputBlockItemData;
93 function AddByteItem(BufPtr: PByte): POutputBlockItemData;
94 function AddBytesItem(BufPtr: PByte): POutputBlockItemData;
95 function AddListItem(BufPtr: PByte): POutputBlockItemData; virtual;
96 function AddSpecialItem(BufPtr: PByte): POutputBlockItemData; virtual;
97 function AddDateTimeItem(BufPtr: PByte): POutputBlockItemData;
98 function AddOctetString(BufPtr: PByte): POutputBlockItemData;
99 public
100 constructor Create(api: TFBClientAPI; aSize: integer = DefaultBufferSize);
101 destructor Destroy; override;
102 function Buffer: PByte;
103 function getBufSize: integer;
104
105 public
106 function GetCount: integer;
107 function GetItem(index: integer): POutputBlockItemData;
108 function Find(ItemType: byte): POutputBlockItemData;
109 procedure PrintBuf;
110 property Count: integer read GetCount;
111 property Items[index: integer]: POutputBlockItemData read getItem; default;
112 end;
113
114 { TOutputBlockItem }
115
116 TOutputBlockItem = class(TFBInterfacedObject,IUnknown)
117 private
118 FOwner: TOutputBlock;
119 FOwnerIntf: IUnknown;
120 FItemData: POutputBlockItemData;
121 protected
122 FFirebirdClientAPI: TFBClientAPI;
123 function GetItem(index: integer): POutputBlockItemData;
124 function Find(ItemType: byte): POutputBlockItemData;
125 procedure SetString(out S: AnsiString; Buf: PByte; Len: integer;
126 CodePage: TSystemCodePage);
127 property ItemData: POutputBlockItemData read FItemData;
128 property Owner: TOutputBlock read FOwner;
129 public
130 constructor Create(AOwner: TOutputBlock; Data: POutputBlockItemData);
131 public
132 function GetCount: integer;
133 function getItemType: byte;
134 function getSize: integer;
135 procedure getRawBytes(var Buffer);
136 function getAsInteger: int64;
137 function getParamType: byte;
138 function getAsString: AnsiString;
139 function getAsByte: byte;
140 function getAsBytes: TByteArray;
141 function getAsDateTime: TDateTime;
142 function CopyTo(stream: TStream; count: integer): integer;
143 end;
144
145 TServiceQueryResultSubItem = class(TOutputBlockItem,IServiceQueryResultSubItem);
146
147 { TCustomOutputBlock }
148
149 {$IFDEF FPC}
150 TCustomOutputBlock<_TItem,_IItem> = class(TOutputBlock)
151 {$ELSE}
152 TOutputBlockItemClass = class of TOutputBlockItem;
153 TCustomOutputBlock<_TItem: TOutputBlockItem;_IItem: IUnknown> = class(TOutputBlock)
154 {$ENDIF}
155 public
156 function getItem(index: integer): _IItem;
157 function find(ItemType: byte): _IItem;
158 property Items[index: integer]: _IItem read getItem; default;
159 end;
160
161 { TOutputBlockItemGroup }
162
163 {$IFDEF FPC}
164 TOutputBlockItemGroup<_TItem,_IItem> = class(TOutputBlockItem)
165 {$ELSE}
166 TOutputBlockItemGroup<_TItem: TOutputBlockItem; _IItem: IUnknown> = class(TOutputBlockItem)
167 {$ENDIF}
168 public
169 function GetItem(index: integer): _IItem;
170 function Find(ItemType: byte): _IItem;
171 property Items[index: integer]: _IItem read getItem; default;
172 end;
173
174 { TDBInfoItem }
175
176 {$IFDEF FPC}
177 TDBInfoItem = class;
178
179 TDBInfoItem = class(TOutputBlockItemGroup<TDBInfoItem,IDBInfoItem>,IDBInfoItem)
180 {$ELSE}
181 TDBInfoItem = class(TOutputBlockItemGroup<TOutputBlockItem,IDBInfoItem>,IDBInfoItem)
182 {$ENDIF}
183 public
184 procedure DecodeIDCluster(var ConnectionType: integer; var DBFileName, DBSiteName: AnsiString);
185 procedure DecodeVersionString(var Version: byte; var VersionString: AnsiString);
186 procedure DecodeUserNames(UserNames: TStrings);
187 function getOperationCounts: TDBOperationCounts;
188 end;
189
190 { TDBInformation }
191
192 TDBInformation = class(TCustomOutputBlock<TDBInfoItem,IDBInfoItem>, IDBInformation)
193 protected
194 function AddSpecialItem(BufPtr: PByte): POutputBlockItemData; override;
195 procedure DoParseBuffer; override;
196 public
197 constructor Create(api: TFBClientAPI; aSize: integer = DefaultBufferSize);
198 {$IFNDEF FPC}
199 function Find(ItemType: byte): IDBInfoItem;
200 {$ENDIF}
201 end;
202
203 { TServiceQueryResultItem }
204
205 TServiceQueryResultItem = class(TOutputBlockItemGroup<TServiceQueryResultSubItem,IServiceQueryResultSubItem>,
206 IServiceQueryResultItem);
207
208 { TServiceQueryResults }
209
210 TServiceQueryResults = class(TCustomOutputBlock<TServiceQueryResultItem,IServiceQueryResultItem>, IServiceQueryResults)
211 protected
212 function AddListItem(BufPtr: PByte): POutputBlockItemData; override;
213 function AddSpecialItem(BufPtr: PByte): POutputBlockItemData; override;
214 procedure DoParseBuffer; override;
215 {$IFNDEF FPC}
216 public
217 function Find(ItemType: byte): IServiceQueryResultItem;
218 {$ENDIF}
219 end;
220
221
222 { ISQLInfoItem }
223
224 ISQLInfoSubItem = interface
225 ['{39852ee4-4851-44df-8dc0-26b991250098}']
226 function getItemType: byte;
227 function getSize: integer;
228 function getAsString: AnsiString;
229 function getAsInteger: int64;
230 end;
231
232 ISQLInfoItem = interface(ISQLInfoSubItem)
233 ['{34e3c39d-fe4f-4211-a7e3-0266495a359d}']
234 function GetCount: integer;
235 function GetItem(index: integer): ISQLInfoSubItem;
236 function Find(ItemType: byte): ISQLInfoSubItem;
237 property Count: integer read GetCount;
238 property Items[index: integer]: ISQLInfoSubItem read getItem; default;
239 end;
240
241 {ISQLInfoResults}
242
243 ISQLInfoResults = interface
244 ['{0b3fbe20-6f80-44e7-85ef-e708bc1f2043}']
245 function GetCount: integer;
246 function GetItem(index: integer): ISQLInfoItem;
247 function Find(ItemType: byte): ISQLInfoItem;
248 property Count: integer read GetCount;
249 property Items[index: integer]: ISQLInfoItem read getItem; default;
250 end;
251
252 TSQLInfoResultsSubItem = class(TOutputBlockItem,ISQLInfoSubItem);
253
254 { TSQLInfoResultsItem }
255
256 TSQLInfoResultsItem = class(TOutputBlockItemGroup<TSQLInfoResultsSubItem,ISQLInfoSubItem>,ISQLInfoItem);
257
258 { TSQLInfoResultsBuffer }
259
260 TSQLInfoResultsBuffer = class(TCustomOutputBlock<TSQLInfoResultsItem,ISQLInfoItem>, ISQLInfoResults)
261 protected
262 function AddListItem(BufPtr: PByte): POutputBlockItemData; override;
263 procedure DoParseBuffer; override;
264 public
265 constructor Create(api: TFBClientAPI; aSize: integer= DefaultBufferSize);
266 end;
267
268 IBlobInfoItem = interface
269 ['{3a55e558-b97f-4cf3-af95-53b84f4d9a65}']
270 function getItemType: byte;
271 function getSize: integer;
272 function getAsString: AnsiString;
273 function getAsInteger: int64;
274 end;
275
276 IBlobInfo = interface
277 ['{8a340109-f600-4d26-ab1d-e0be2c759f1c}']
278 function GetCount: integer;
279 function GetItem(index: integer): IBlobInfoItem;
280 function Find(ItemType: byte): IBlobInfoItem;
281 property Count: integer read GetCount;
282 property Items[index: integer]: IBlobInfoItem read getItem; default;
283 end;
284
285 {$IFDEF FPC}
286 TBlobInfoItem = class;
287
288 TBlobInfoItem = class(TOutputBlockItemGroup<TBlobInfoItem,IBlobInfoItem>,IBlobInfoItem)
289 {$ELSE}
290 TBlobInfoItem = class(TOutputBlockItemGroup<TOutputBlockItem,IBlobInfoItem>,IBlobInfoItem)
291 {$ENDIF}
292
293 end;
294
295 { TBlobInfo }
296
297 TBlobInfo = class(TCustomOutputBlock<TBlobInfoItem,IBlobInfoItem>, IBlobInfo)
298 protected
299 procedure DoParseBuffer; override;
300 public
301 constructor Create(api: TFBClientAPI; aSize: integer = DefaultBufferSize);
302 end;
303
304 implementation
305
306 uses FBMessages {$IFNDEF FPC}, TypInfo {$ENDIF};
307
308 function BufToStr(P: PByte; Len: integer):AnsiString;
309 begin
310 SetLength(Result,Len);
311 Move(P^,Result[1],Len);
312 end;
313
314 {$IFDEF FPC}
315 { TOutputBlockItemGroup }
316
317 function TOutputBlockItemGroup<_TItem,_IItem>.GetItem(index: integer): _IItem;
318 var P: POutputBlockItemData;
319 begin
320 P := inherited getItem(index);
321 Result := _TItem.Create(self.Owner,P);
322 end;
323
324 function TOutputBlockItemGroup<_TItem,_IItem>.Find(ItemType: byte): _IItem;
325 var P: POutputBlockItemData;
326 begin
327 P := inherited Find(ItemType);
328 Result := _TItem.Create(self.Owner,P);
329 end;
330
331 { TCustomOutputBlock }
332
333 function TCustomOutputBlock<_TItem,_IItem>.getItem(index: integer): _IItem;
334 var P: POutputBlockItemData;
335 begin
336 P := inherited getItem(index);
337 Result := _TItem.Create(self,P)
338 end;
339
340 function TCustomOutputBlock<_TItem,_IItem>.find(ItemType: byte): _IItem;
341 var P: POutputBlockItemData;
342 begin
343 P := inherited Find(ItemType);
344 if P = nil then
345 Result := nil
346 else
347 Result := _TItem.Create(self,P)
348 end;
349
350 {$ELSE}
351
352 { TOutputBlockItemGroup }
353
354 function TOutputBlockItemGroup<_TItem,_IItem>.GetItem(index: integer): _IItem;
355 var P: POutputBlockItemData;
356 Obj: TOutputBlockItem;
357 begin
358 P := inherited getItem(index);
359 Obj := TOutputBlockItemClass(_TItem).Create(self.Owner,P);
360 if Obj.QueryInterface(GetTypeData(TypeInfo(_IItem))^.Guid,Result) <> 0 then
361 IBError(ibxeInterfaceNotSupported,[GuidToString(GetTypeData(TypeInfo(_IItem))^.Guid)]);
362 end;
363
364 function TOutputBlockItemGroup<_TItem,_IItem>.Find(ItemType: byte): _IItem;
365 var P: POutputBlockItemData;
366 Obj: TOutputBlockItem;
367 begin
368 P := inherited Find(ItemType);
369 if P = nil then
370 Result := Default(_IITEM)
371 else
372 begin
373 Obj := TOutputBlockItemClass(_TItem).Create(self.Owner,P);
374 if Obj.QueryInterface(GetTypeData(TypeInfo(_IItem))^.Guid,Result) <> 0 then
375 IBError(ibxeInterfaceNotSupported,[GuidToString(GetTypeData(TypeInfo(_IItem))^.Guid)]);
376 end;
377 end;
378
379 { TCustomOutputBlock }
380
381 function TCustomOutputBlock<_TItem,_IItem>.getItem(index: integer): _IItem;
382 var P: POutputBlockItemData;
383 Obj: TOutputBlockItem;
384 begin
385 P := inherited getItem(index);
386 Obj := TOutputBlockItemClass(_TItem).Create(self,P);
387 if Obj.QueryInterface(GetTypeData(TypeInfo(_IItem))^.Guid,Result) <> 0 then
388 IBError(ibxeInterfaceNotSupported,[GuidToString(GetTypeData(TypeInfo(_IItem))^.Guid)]);
389 end;
390
391 function TCustomOutputBlock<_TItem,_IItem>.find(ItemType: byte): _IItem;
392 var P: POutputBlockItemData;
393 Obj: TOutputBlockItem;
394 begin
395 P := inherited Find(ItemType);
396 Obj := TOutputBlockItemClass(_TItem).Create(self,P);
397 if Obj.QueryInterface(GetTypeData(TypeInfo(_IItem))^.Guid,Result) <> 0 then
398 IBError(ibxeInterfaceNotSupported,[GuidToString(GetTypeData(TypeInfo(_IItem))^.Guid)]);
399 end;
400
401 {$ENDIF}
402
403 { TOutputBlockItem }
404
405 function TOutputBlockItem.GetCount: integer;
406 begin
407 Result := Length(FItemData^.FSubItems);
408 end;
409
410 function TOutputBlockItem.GetItem(index: integer): POutputBlockItemData;
411 begin
412 if (index >= 0) and (index < Length(FItemData^.FSubItems)) then
413 Result := FItemData^.FSubItems[index]
414 else
415 with FFirebirdClientAPI do
416 IBError(ibxeOutputBlockIndexError,[index]);
417 end;
418
419 function TOutputBlockItem.Find(ItemType: byte): POutputBlockItemData;
420 var i: integer;
421 begin
422 Result := nil;
423 for i := 0 to GetCount - 1 do
424 if byte(FItemData^.FSubItems[i]^.FBufPtr^) = ItemType then
425 begin
426 Result := FItemData^.FSubItems[i];
427 Exit;
428 end;
429 end;
430
431 { TOutputBlockItem }
432
433 procedure TOutputBlockItem.SetString(out S: AnsiString; Buf: PByte;
434 Len: integer; CodePage: TSystemCodePage);
435 var rs: RawByteString;
436 i: integer;
437 begin
438 {There seems to be a memory manager problem with SetString that can cause
439 an unhandled exception at the end of a program if it is used to set the
440 string. Safer to copy characters one by one. Note that Setlength does
441 not work around the bug either.}
442 rs := '';
443 for i := 0 to len-1 do
444 rs := rs + PAnsiChar(buf+i)^;
445 // system.SetString(rs,PAnsiChar(Buf),len);
446 SetCodePage(rs,CodePage,false);
447 S := rs;
448 end;
449
450 constructor TOutputBlockItem.Create(AOwner: TOutputBlock;
451 Data: POutputBlockItemData);
452 begin
453 inherited Create;
454 FOwner := AOwner;
455 FOwnerIntf := AOwner;
456 FFirebirdClientAPI := AOwner.FFirebirdClientAPI;
457 FItemData := Data;
458 end;
459
460 function TOutputBlockItem.getItemType: byte;
461 begin
462 Result := byte(FItemData^.FBufPtr^);
463 end;
464
465 function TOutputBlockItem.getSize: integer;
466 begin
467 if FItemData = nil then
468 Result := 0
469 else
470 Result := FItemData^.FDataLength;
471 end;
472
473 procedure TOutputBlockItem.getRawBytes(var Buffer);
474 begin
475 with FItemData^ do
476 Move(FBufPtr^,Buffer,FDatalength);
477 end;
478
479 function TOutputBlockItem.getAsInteger: int64;
480 var len: integer;
481 begin
482 with FItemData^ do
483 case FDataType of
484 dtIntegerFixed:
485 with FFirebirdClientAPI do
486 Result := DecodeInteger(FBufPtr+1,4);
487
488 dtShortIntFixed:
489 with FFirebirdClientAPI do
490 Result := DecodeInteger(FBufPtr+1,2);
491
492 dtTinyInteger:
493 with FFirebirdClientAPI do
494 begin
495 len := DecodeInteger(FBufPtr+1,1);
496 Result := DecodeInteger(FBufPtr+2,len);
497 end;
498
499 dtByte,
500 dtInteger:
501 with FFirebirdClientAPI do
502 begin
503 len := DecodeInteger(FBufPtr+1,2);
504 Result := DecodeInteger(FBufPtr+3,len);
505 end;
506 else
507 IBError(ibxeOutputBlockTypeError,[nil]);
508 end;
509 end;
510
511 function TOutputBlockItem.getParamType: byte;
512 begin
513 Result := byte(FItemData^.FBufPtr^)
514 end;
515
516 function TOutputBlockItem.getAsString: AnsiString;
517 var len: integer;
518 begin
519 Result := '';
520 with FItemData^ do
521 case FDataType of
522 dtIntegerFixed,
523 dtInteger:
524 Result := IntToStr(getAsInteger);
525 dtByte:
526 Result := IntToStr(getAsByte);
527 dtString:
528 begin
529 len := byte((FBufPtr+1)^);
530 SetString(Result,FBufPtr+2,len,CP_ACP);
531 end;
532 dtString2:
533 begin
534 with FFirebirdClientAPI do
535 len := DecodeInteger(FBufPtr+1,2);
536 SetString(Result,FBufPtr+3,len,CP_ACP);
537 end;
538 dtOctetString:
539 begin
540 with FFirebirdClientAPI do
541 len := DecodeInteger(FBufPtr+1,2);
542 SetString(Result,FBufPtr+3,len,CP_NONE);
543 end;
544 else
545 IBError(ibxeOutputBlockTypeError,[nil]);
546 end;
547 end;
548
549 function TOutputBlockItem.getAsByte: byte;
550 begin
551 with FItemData^ do
552 if FDataType = dtByte then
553 Result := byte((FBufPtr+2)^)
554 else
555 IBError(ibxeOutputBlockTypeError,[nil]);
556 end;
557
558 function TOutputBlockItem.getAsBytes: TByteArray;
559 var i: integer;
560 P: PByte;
561 begin
562 with FItemData^ do
563 if FDataType = dtBytes then
564 begin
565 SetLength(Result,FDataLength);
566 P := FBufPtr;
567 for i := 0 to FDataLength - 1 do
568 begin
569 Result[i] := byte(P^);
570 Inc(P);
571 end
572 end
573 else
574 IBError(ibxeOutputBlockTypeError,[nil]);
575 end;
576
577 function TOutputBlockItem.getAsDateTime: TDateTime;
578 var aDate: integer;
579 aTime: integer;
580 begin
581 with FItemData^, FFirebirdClientAPI do
582 if FDataType = dtDateTime then
583 begin
584 aDate := DecodeInteger(FBufPtr+3,4);
585 aTime := DecodeInteger(FBufPtr+7,4);
586 Result := SQLDecodeDate(@aDate) + SQLDecodeTime(@aTime)
587 end
588 else
589 IBError(ibxeOutputBlockTypeError,[nil]);
590 end;
591
592
593 function TOutputBlockItem.CopyTo(stream: TStream; count: integer): integer;
594 var len: integer;
595 begin
596 if count < 0 then count := 0;
597 with FItemData^ do
598 begin
599 case FDataType of
600 dtString:
601 begin
602 len := byte((FBufPtr+1)^);
603 if (count > 0) and (count < len) then len := count;
604 Result := stream.Write((FBufPtr+2)^,len);
605 end;
606 dtString2:
607 begin
608 with FFirebirdClientAPI do
609 len := DecodeInteger(FBufPtr+1,2);
610 if (count > 0) and (count < len) then len := count;
611 Result := stream.Write((FBufPtr+3)^,len);
612 end;
613 else
614 IBError(ibxeOutputBlockTypeError,[nil]);
615 end;
616 end;
617 end;
618
619 { TOutputBlock }
620
621 procedure TOutputBlock.ParseBuffer;
622 begin
623 if not FBufferParsed then
624 begin
625 {$IFDEF DEBUGOUTPUTBLOCK}
626 PrintBuf;
627 {$ENDIF}
628 DoParseBuffer;
629 if FError or FTruncated then
630 SetLength(FItems,Length(FItems)-1);
631 {$IFDEF DEBUGOUTPUTBLOCK}
632 FormattedPrint(FItems,'');
633 {$ENDIF}
634 end;
635 FBufferParsed := true;
636 end;
637
638 function TOutputBlock.AddItem(BufPtr: PByte): POutputBlockItemData;
639 begin
640 new(Result);
641 with Result^ do
642 begin
643 FDataType := dtNone;
644 FBufPtr := BufPtr;
645 FDataLength := 0;
646 FSize := 1;
647 SetLength(FSubItems,0);
648 end;
649 end;
650
651 function TOutputBlock.AddIntegerItem(BufPtr: PByte; IntType: TItemDataType
652 ): POutputBlockItemData;
653 begin
654 new(Result);
655 with Result^ do
656 begin
657 FDataType := IntType;
658 FBufPtr := BufPtr;
659 case FDataType of
660 dtIntegerFixed:
661 begin
662 FDataLength := 4;
663 FSize := 5;
664 end;
665
666 dtShortIntFixed:
667 begin
668 FDataLength := 2;
669 FSize := 3;
670 end;
671
672 dtTinyInteger:
673 begin
674 with FFirebirdClientAPI do
675 FDataLength := DecodeInteger(FBufPtr+1, 1);
676 FSize := FDataLength + 2;
677 end;
678
679 else
680 begin
681 with FFirebirdClientAPI do
682 FDataLength := DecodeInteger(FBufPtr+1, 2);
683 FSize := FDataLength + 3;
684 end;
685 end;
686 SetLength(FSubItems,0);
687 end;
688 end;
689
690 function TOutputBlock.AddIntegerItem(BufPtr: PByte): POutputBlockItemData;
691 begin
692 Result := AddIntegerItem(BufPtr,FIntegerType);
693 end;
694
695 function TOutputBlock.AddStringItem(BufPtr: PByte): POutputBlockItemData;
696 begin
697 new(Result);
698 with Result^ do
699 begin
700 FDataType := dtString2;
701 FBufPtr := BufPtr;
702 with FFirebirdClientAPI do
703 FDataLength := DecodeInteger(FBufPtr+1, 2);
704 FSize := FDataLength + 3;
705 SetLength(FSubItems,0);
706 end;
707 end;
708
709 function TOutputBlock.AddShortStringItem(BufPtr: PByte): POutputBlockItemData;
710 begin
711 new(Result);
712 with Result^ do
713 begin
714 FDataType := dtString;
715 FBufPtr := BufPtr;
716 FDataLength := byte((FBufPtr+1)^);
717 FSize := FDataLength + 2;
718 SetLength(FSubItems,0);
719 end;
720 end;
721
722 function TOutputBlock.AddByteItem(BufPtr: PByte): POutputBlockItemData;
723 begin
724 new(Result);
725 with Result^ do
726 begin
727 FDataType := dtByte;
728 FBufPtr := BufPtr;
729 FDataLength := 1;
730 FSize := 2;
731 SetLength(FSubItems,0);
732 end;
733 end;
734
735 function TOutputBlock.AddBytesItem(BufPtr: PByte): POutputBlockItemData;
736 begin
737 new(Result);
738 with Result^ do
739 begin
740 FDataType := dtBytes;
741 FBufPtr := BufPtr;
742 with FFirebirdClientAPI do
743 FDataLength := DecodeInteger(FBufPtr+1, 2);
744 FSize := FDataLength + 3;
745 SetLength(FSubItems,0);
746 end;
747 end;
748
749 function TOutputBlock.AddListItem(BufPtr: PByte): POutputBlockItemData;
750 begin
751 new(Result);
752 with Result^ do
753 begin
754 FDataType := dtList;
755 FBufPtr := BufPtr;
756 FSize := FBuffer + FBufSize - FBufPtr;
757 FDataLength := FSize - 1;
758 SetLength(FSubItems,0);
759 end;
760 end;
761
762 function TOutputBlock.AddSpecialItem(BufPtr: PByte): POutputBlockItemData;
763 begin
764 new(Result);
765 with Result^ do
766 begin
767 FDataType := dtSpecial;
768 FBufPtr := BufPtr;
769 FSize := FBuffer + FBufSize - FBufPtr;
770 FDataLength := FSize - 1;
771 SetLength(FSubItems,0);
772 end;
773 end;
774
775 function TOutputBlock.AddDateTimeItem(BufPtr: PByte): POutputBlockItemData;
776 begin
777 new(Result);
778 with Result^ do
779 begin
780 FDataType := dtDateTime;
781 FBufPtr := BufPtr;
782 with FFirebirdClientAPI do
783 FDataLength := DecodeInteger(FBufPtr+1, 2);
784 FSize := FDataLength + 3;
785 SetLength(FSubItems,0);
786 end;
787 end;
788
789 function TOutputBlock.AddOctetString(BufPtr: PByte): POutputBlockItemData;
790 begin
791 new(Result);
792 with Result^ do
793 begin
794 FDataType := dtOctetString;
795 FBufPtr := BufPtr;
796 with FFirebirdClientAPI do
797 FDataLength := DecodeInteger(FBufPtr+1, 2);
798 FSize := FDataLength + 3;
799 SetLength(FSubItems,0);
800 end;
801 end;
802
803 constructor TOutputBlock.Create(api: TFBClientAPI; aSize: integer);
804 begin
805 inherited Create;
806 FFirebirdClientAPI := api;
807 FBufSize := aSize;
808 GetMem(FBuffer,aSize);
809 if FBuffer = nil then
810 OutOfMemoryError;
811 FillChar(FBuffer^,aSize,255);
812 FBufferParsed := false;
813 FIntegerType := dtIntegerFixed;
814 end;
815
816 destructor TOutputBlock.Destroy;
817 var i, j: integer;
818 begin
819 for i := 0 to length(FItems) - 1 do
820 begin
821 if FItems[i] <> nil then
822 begin
823 for j := 0 to Length(FItems[i]^.FSubItems) -1 do
824 if FItems[i]^.FSubItems[j] <> nil then
825 dispose(FItems[i]^.FSubItems[j]);
826 dispose(FItems[i]);
827 end;
828 end;
829 FreeMem(FBuffer);
830 inherited Destroy;
831 end;
832
833 function TOutputBlock.Buffer: PByte;
834 begin
835 Result := FBuffer;
836 end;
837
838 function TOutputBlock.getBufSize: integer;
839 begin
840 Result := FBufSize;
841 end;
842
843 function TOutputBlock.GetCount: integer;
844 begin
845 ParseBuffer;
846 Result := length(FItems);
847 end;
848
849 function TOutputBlock.GetItem(index: integer): POutputBlockItemData;
850 begin
851 ParseBuffer;
852 if (index >= 0) and (index < Length(FItems)) then
853 Result := FItems[index]
854 else
855 IBError(ibxeOutputBlockIndexError,[index]);
856 end;
857
858 function TOutputBlock.Find(ItemType: byte): POutputBlockItemData;
859 var i: integer;
860 begin
861 Result := nil;
862 for i := 0 to getCount - 1 do
863 if byte(FItems[i]^.FBufPtr^) = ItemType then
864 begin
865 Result := FItems[i];
866 Exit;
867 end;
868 end;
869
870 {$IFDEF DEBUGOUTPUTBLOCK}
871 procedure TOutputBlock.FormattedPrint(
872 const aItems: array of POutputBlockItemData; Indent: AnsiString);
873
874 var i: integer;
875 item: TOutputBlockItem;
876 begin
877 if FError then
878 writeln('Error')
879 else
880 if FTruncated then
881 writeln('Truncated')
882 else
883 for i := 0 to Length(aItems) - 1 do
884 with aItems[i]^ do
885 begin
886 if FError then
887 writeln('Error')
888 else
889 if FTruncated then
890 writeln('Truncated')
891 else
892 case FDataType of
893 dtList:
894 begin
895 writeln(Indent,'ItemType = ',byte(FBufPtr^));
896 FormattedPrint(FSubItems,Indent + ' ');
897 end;
898 dtSpecial:
899 writeln(Indent,'ItemType = ',byte(FBufPtr^),' Length = ',FSize);
900 else
901 begin
902 item := TOutputBlockItem.Create(self,(aItems[i]));
903 try
904 writeln(Indent,'ItemType = ',byte(FBufPtr^),' Value = ',(item as TOutputBlockItem).GetAsString);
905 except
906 writeln(Indent,'Unknown ItemType = ',byte(FBufPtr^));
907 end;
908 end;
909 end;
910 end;
911 end;
912 {$ENDIF}
913
914 procedure TOutputBlock.PrintBuf;
915 var i: integer;
916 begin
917 write(classname,': ');
918 for i := 0 to getBufSize - 1 do
919 begin
920 if byte(FBuffer[i]) = $FF then break;
921 write(Format('%x ',[byte(Buffer[i])]));
922 // if byte(FBuffer[i]) = isc_info_end then break;
923 end;
924 writeln;
925 for i := 0 to getBufSize - 1 do
926 begin
927 if byte(FBuffer[i]) = $FF then break;
928 if chr(FBuffer[i]) in [' '..'~'] then
929 write(chr(Buffer[i]))
930 else
931 write('.');
932 // if byte(FBuffer[i]) = isc_info_end then break;
933 end;
934 writeln;
935 end;
936
937 { TDBInfoItem }
938
939 procedure TDBInfoItem.DecodeIDCluster(var ConnectionType: integer;
940 var DBFileName, DBSiteName: AnsiString);
941 var P: PByte;
942 begin
943 with ItemData^ do
944 if FBufPtr^ = isc_info_db_id then
945 begin
946 P := FBufPtr + 3;
947 if FDataLength > 0 then
948 ConnectionType := integer(P^);
949 Inc(P);
950 SetString(DBFileName,P+1,byte(P^),CP_ACP);
951 P := P + Length(DBFileName) + 1;
952 SetString(DBSiteName,P+1,byte(P^),CP_ACP);
953 end
954 else
955 IBError(ibxeInfoBufferTypeError,[integer(FBufPtr^)]);
956 end;
957
958 procedure TDBInfoItem.DecodeVersionString(var Version: byte;
959 var VersionString: AnsiString);
960 var P: PByte;
961 begin
962 with ItemData^ do
963 if FBufPtr^ = isc_info_version then
964 begin
965 P := FBufPtr+3;
966 VersionString := '';
967 Version := byte(P^);
968 Inc(P);
969 SetString(VersionString,P+1,byte(P^),CP_ACP);
970 end
971 else
972 IBError(ibxeInfoBufferTypeError,[integer(FBufPtr^)]);
973 end;
974
975 procedure TDBInfoItem.DecodeUserNames(UserNames: TStrings);
976 var P: PByte;
977 s: AnsiString;
978 begin
979 with ItemData^ do
980 if FBufPtr^ = isc_info_user_names then
981 begin
982 P := FBufPtr+3;
983 while (P < FBufPtr + FSize) do
984 begin
985 SetString(s,P+1,byte(P^),CP_ACP);
986 UserNames.Add(s);
987 P := P + Length(s) + 1;
988 end;
989 end
990 else
991 IBError(ibxeInfoBufferTypeError,[integer(FBufPtr^)]);
992 end;
993
994 function TDBInfoItem.getOperationCounts: TDBOperationCounts;
995 var tableCounts: integer;
996 P: PByte;
997 i: integer;
998 begin
999 with ItemData^ do
1000 if byte(FBufPtr^) in [isc_info_backout_count, isc_info_delete_count,
1001 isc_info_expunge_count,isc_info_insert_count, isc_info_purge_count,
1002 isc_info_read_idx_count, isc_info_read_seq_count, isc_info_update_count] then
1003 begin
1004 tableCounts := FDataLength div 6;
1005 SetLength(Result,TableCounts);
1006 P := FBufPtr + 3;
1007 for i := 0 to TableCounts -1 do
1008 with FFirebirdClientAPI do
1009 begin
1010 Result[i].TableID := DecodeInteger(P,2);
1011 Inc(P,2);
1012 Result[i].Count := DecodeInteger(P,4);
1013 Inc(P,4);
1014 end;
1015 end
1016 else
1017 IBError(ibxeInfoBufferTypeError,[integer(FBufPtr^)]);
1018 end;
1019
1020 { TDBInformation }
1021
1022 function TDBInformation.AddSpecialItem(BufPtr: PByte): POutputBlockItemData;
1023 begin
1024 Result := inherited AddSpecialItem(BufPtr);
1025 with Result^ do
1026 begin
1027 with FFirebirdClientAPI do
1028 FDataLength := DecodeInteger(FBufPtr+1,2);
1029 FSize := FDataLength + 3;
1030 end;
1031 end;
1032
1033 procedure TDBInformation.DoParseBuffer;
1034 var P: PByte;
1035 index: integer;
1036 begin
1037 P := Buffer;
1038 index := 0;
1039 SetLength(FItems,0);
1040 while (P^ <> isc_info_end) and (P < Buffer + getBufSize) do
1041 begin
1042 SetLength(FItems,index+1);
1043 case byte(P^) of
1044 isc_info_db_read_only,
1045 isc_info_no_reserve,
1046 isc_info_allocation,
1047 isc_info_ods_minor_version,
1048 isc_info_ods_version,
1049 isc_info_db_SQL_dialect,
1050 isc_info_page_size,
1051 isc_info_current_memory,
1052 isc_info_forced_writes,
1053 isc_info_max_memory,
1054 isc_info_num_buffers,
1055 isc_info_sweep_interval,
1056 isc_info_fetches,
1057 isc_info_marks,
1058 isc_info_reads,
1059 isc_info_writes,
1060 isc_info_active_tran_count,
1061 isc_info_attachment_id,
1062 fb_info_pages_used,
1063 fb_info_pages_free,
1064 fb_info_conn_flags:
1065 FItems[index] := AddIntegerItem(P);
1066
1067 isc_info_implementation,
1068 isc_info_base_level:
1069 FItems[index] := AddBytesItem(P);
1070
1071 isc_info_creation_date:
1072 FItems[index] := AddDateTimeItem(P);
1073
1074 fb_info_page_contents:
1075 FItems[index] := AddOctetString(P);
1076
1077 fb_info_crypt_key:
1078 FItems[index] := AddStringItem(P);
1079
1080 isc_info_db_id,
1081 isc_info_version,
1082 isc_info_backout_count,
1083 isc_info_delete_count,
1084 isc_info_expunge_count,
1085 isc_info_insert_count,
1086 isc_info_purge_count,
1087 isc_info_read_idx_count,
1088 isc_info_read_seq_count,
1089 isc_info_update_count,
1090 isc_info_user_names:
1091 FItems[index] := AddSpecialItem(P);
1092
1093 else
1094 FItems[index] := AddSpecialItem(P);
1095 end;
1096 P := P + FItems[index]^.FSize;
1097 Inc(index);
1098 end;
1099 end;
1100
1101 {$IFNDEF FPC}
1102 function TDBInformation.Find(ItemType: byte): IDBInfoItem;
1103 begin
1104 Result := inherited Find(ItemType);
1105 if Result.GetSize = 0 then
1106 Result := nil;
1107 end;
1108 {$ENDIF}
1109
1110 constructor TDBInformation.Create(api: TFBClientAPI; aSize: integer);
1111 begin
1112 inherited Create(api,aSize);
1113 FIntegerType := dtInteger;
1114 end;
1115
1116 { TServiceQueryResults }
1117
1118 function TServiceQueryResults.AddListItem(BufPtr: PByte): POutputBlockItemData;
1119 var P: PByte;
1120 i: integer;
1121 group: byte;
1122 begin
1123 Result := inherited AddListItem(BufPtr);
1124 P := BufPtr + 1;
1125 i := 0;
1126 group := byte(BufPtr^);
1127 if group in [isc_info_svc_get_users,isc_info_svc_limbo_trans] then
1128 begin
1129 with FFirebirdClientAPI do
1130 Result^.FSize := DecodeInteger(P,2) + 3;
1131 Inc(P,2);
1132 end;
1133 with Result^ do
1134 begin
1135 while (P < FBufPtr + FSize) and (P^ <> isc_info_flag_end) do
1136 begin
1137 SetLength(FSubItems,i+1);
1138 FSubItems[i] := nil;
1139 case group of
1140 isc_info_svc_svr_db_info:
1141 case integer(P^) of
1142 isc_spb_num_att,
1143 isc_spb_num_db:
1144 FSubItems[i] := AddIntegerItem(P);
1145
1146 isc_spb_dbname:
1147 FSubItems[i] := AddStringItem(P);
1148
1149 else
1150 IBError(ibxeOutputParsingError, [integer(P^),BufToStr(P,FSize - (P-FBufPtr))]);
1151 end;
1152
1153 isc_info_svc_get_license:
1154 case integer(P^) of
1155 isc_spb_lic_id,
1156 isc_spb_lic_key:
1157 FSubItems[i] := AddIntegerItem(P);
1158 else
1159 IBError(ibxeOutputParsingError, [integer(P^),BufToStr(P,FSize - (P-FBufPtr))]);
1160 end;
1161
1162 isc_info_svc_limbo_trans:
1163 case integer(P^) of
1164 isc_spb_tra_id,
1165 isc_spb_single_tra_id,
1166 isc_spb_multi_tra_id:
1167 FSubItems[i] := AddIntegerItem(P);
1168
1169 isc_spb_tra_host_site,
1170 isc_spb_tra_remote_site,
1171 isc_spb_tra_db_path:
1172 FSubItems[i] := AddStringItem(P);
1173
1174 isc_spb_tra_advise,
1175 isc_spb_tra_state:
1176 FSubItems[i] := AddByteItem(P);
1177 else
1178 IBError(ibxeOutputParsingError, [integer(P^),BufToStr(P,FSize - (P-FBufPtr))]);
1179 end;
1180
1181 isc_info_svc_get_users:
1182 case integer(P^) of
1183 isc_spb_sec_admin,
1184 isc_spb_sec_userid,
1185 isc_spb_sec_groupid:
1186 FSubItems[i] := AddIntegerItem(P);
1187
1188 isc_spb_sec_username,
1189 isc_spb_sec_password,
1190 isc_spb_sec_firstname,
1191 isc_spb_sec_middlename,
1192 isc_spb_sec_lastname:
1193 FSubItems[i] := AddStringItem(P);
1194
1195 else
1196 IBError(ibxeOutputParsingError, [integer(P^),BufToStr(P,FSize - (P-FBufPtr))]);
1197 end;
1198
1199 end;
1200 P := P + FSubItems[i]^.FSize;
1201 Inc(i);
1202 end;
1203 FDataLength := 0;
1204 for i := 0 to Length(FSubItems) - 1 do
1205 FDataLength := FDataLength + FSubItems[i]^.FSize;
1206 if group in [isc_info_svc_get_users,isc_info_svc_limbo_trans] then
1207 Exit;
1208
1209 if (P < FBufPtr + FSize) and (P^ = isc_info_flag_end) then
1210 FSize := FDataLength + 2 {include start and end flag}
1211 else
1212 FSize := FDataLength + 1; {start flag only}
1213 end;
1214 end;
1215
1216 function TServiceQueryResults.AddSpecialItem(BufPtr: PByte
1217 ): POutputBlockItemData;
1218 var P: PByte;
1219 i: integer;
1220 begin
1221 Result := inherited AddSpecialItem(BufPtr);
1222 with Result^ do
1223 begin
1224 with FFirebirdClientAPI do
1225 FDataLength := DecodeInteger(FBufPtr+1, 2);
1226
1227 P := FBufPtr + 3; {skip length bytes}
1228 i := 0;
1229 while P < FBufPtr + FDataLength do
1230 begin
1231 FSubItems[i] := AddIntegerItem(P);
1232 P := P + FSubItems[i]^.FSize;
1233 Inc(i);
1234 end;
1235 end;
1236 end;
1237
1238 procedure TServiceQueryResults.DoParseBuffer;
1239 var P: PByte;
1240 i: integer;
1241 begin
1242 P := Buffer;
1243 i := 0;
1244 while (P < Buffer + getBufSize) and (P^ <> isc_info_end) do
1245 begin
1246 SetLength(FItems,i+1);
1247 FItems[i] := nil;
1248 case integer(P^) of
1249 isc_info_svc_line,
1250 isc_info_svc_get_env,
1251 isc_info_svc_get_env_lock,
1252 isc_info_svc_get_env_msg,
1253 isc_info_svc_user_dbpath,
1254 isc_info_svc_server_version,
1255 isc_info_svc_implementation,
1256 isc_info_svc_to_eof:
1257 FItems[i] := AddStringItem(P);
1258
1259 isc_info_svc_get_license_mask,
1260 isc_info_svc_capabilities,
1261 isc_info_svc_version,
1262 isc_info_svc_running,
1263 isc_info_svc_stdin:
1264 FItems[i] := AddIntegerItem(P);
1265
1266 isc_info_svc_timeout,
1267 isc_info_data_not_ready,
1268 isc_info_truncated:
1269 FItems[i] := AddItem(P);
1270
1271 isc_info_svc_svr_db_info,
1272 isc_info_svc_get_license,
1273 isc_info_svc_limbo_trans,
1274 isc_info_svc_get_users:
1275 FItems[i] := AddListItem(P);
1276
1277 isc_info_svc_get_config:
1278 FItems[i] := AddSpecialItem(P);
1279
1280
1281 else
1282 IBError(ibxeOutputParsingError, [integer(P^),BufToStr(P,getBufSize - (P-Buffer))]);
1283 end;
1284 P := P + FItems[i]^.FSize;
1285 Inc(i);
1286 end;
1287 end;
1288
1289 {$IFNDEF FPC}
1290 function TServiceQueryResults.Find(ItemType: byte): IServiceQueryResultItem;
1291 begin
1292 Result := inherited Find(ItemType);
1293 if Result.GetSize = 0 then
1294 Result := nil;
1295 end;
1296 {$ENDIF}
1297
1298 { TSQLInfoResultsBuffer }
1299
1300 function TSQLInfoResultsBuffer.AddListItem(BufPtr: PByte): POutputBlockItemData;
1301 var P: PByte;
1302 i: integer;
1303 begin
1304 Result := inherited AddListItem(BufPtr);
1305 P := BufPtr + 1;
1306 i := 0;
1307
1308 if byte(BufPtr^) = isc_info_sql_records then
1309 begin
1310 with FFirebirdClientAPI do
1311 Result^.FSize := DecodeInteger(P,2) + 3;
1312 Inc(P,2);
1313 with Result^ do
1314 begin
1315 while (P < FBufPtr + FSize) and (byte(P^) <> isc_info_end) do
1316 begin
1317 SetLength(FSubItems,i+1);
1318 case integer(P^) of
1319 isc_info_req_select_count,
1320 isc_info_req_insert_count,
1321 isc_info_req_update_count,
1322 isc_info_req_delete_count:
1323 FSubItems[i] := AddIntegerItem(P);
1324
1325 isc_info_truncated:
1326 begin
1327 FTruncated := true;
1328 Exit;
1329 end;
1330
1331 isc_info_error:
1332 begin
1333 FError := true;
1334 Exit;
1335 end;
1336 else
1337 FSubItems[i] := AddSpecialItem(P);
1338 end;
1339 P := P + FSubItems[i]^.FSize;
1340 Inc(i);
1341 end;
1342 end;
1343 end;
1344 end;
1345
1346 procedure TSQLInfoResultsBuffer.DoParseBuffer;
1347 var P: PByte;
1348 index: integer;
1349 begin
1350 P := Buffer;
1351 index := 0;
1352 SetLength(FItems,0);
1353 while (P^ <> isc_info_end) and (P < Buffer + getBufSize) do
1354 begin
1355 SetLength(FItems,index+1);
1356 case byte(P^) of
1357 isc_info_sql_stmt_type:
1358 FItems[index] := AddIntegerItem(P);
1359
1360 isc_info_sql_get_plan:
1361 FItems[index] := AddStringItem(P);
1362
1363 isc_info_sql_records:
1364 FItems[index] := AddListItem(P);
1365
1366 isc_info_truncated:
1367 begin
1368 FTruncated := true;
1369 Exit;
1370 end;
1371
1372 isc_info_error:
1373 begin
1374 FError := true;
1375 Exit;
1376 end;
1377
1378 else
1379 FItems[index] := AddSpecialItem(P);
1380 end;
1381 P := P + FItems[index]^.FSize;
1382 Inc(index);
1383 end;
1384 end;
1385
1386 constructor TSQLInfoResultsBuffer.Create(api: TFBClientAPI; aSize: integer);
1387 begin
1388 inherited Create(api,aSize);
1389 FIntegerType := dtInteger;
1390 end;
1391
1392 { TBlobInfo }
1393
1394 procedure TBlobInfo.DoParseBuffer;
1395 var P: PByte;
1396 index: integer;
1397 begin
1398 P := Buffer;
1399 index := 0;
1400 SetLength(FItems,0);
1401 while (P^ <> isc_info_end) and (P < Buffer + getBufSize) do
1402 begin
1403 SetLength(FItems,index+1);
1404 case byte(P^) of
1405 isc_info_blob_num_segments,
1406 isc_info_blob_max_segment,
1407 isc_info_blob_total_length,
1408 isc_info_blob_type:
1409 FItems[index] := AddIntegerItem(P);
1410 else
1411 FItems[index] := AddSpecialItem(P);
1412 end;
1413 P := P + FItems[index]^.FSize;
1414 Inc(index);
1415 end;
1416 end;
1417
1418 constructor TBlobInfo.Create(api: TFBClientAPI; aSize: integer);
1419 begin
1420 inherited Create(api,aSize);
1421 FIntegerType := dtInteger;
1422 end;
1423
1424 end.
1425