ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBOutputBlock.pas
Revision: 263
Committed: Thu Dec 6 15:55:01 2018 UTC (5 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 35454 byte(s)
Log Message:
Release 2.3.2 committed

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