ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBOutputBlock.pas
Revision: 56
Committed: Mon Mar 6 10:20:02 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
File size: 31475 byte(s)
Log Message:
Committing updates for Trunk

File Contents

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