1{ 2 This file is part of the Free Component Library (FCL) 3 Copyright (c) 1999-2000 by the Free Pascal development team 4 5 See the file COPYING.FPC, included in this distribution, 6 for details about the copyright. 7 8 This program is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 12 **********************************************************************} 13{****************************************************************************} 14{* TBinaryObjectReader *} 15{****************************************************************************} 16 17{$ifndef FPUNONE} 18{$IFNDEF FPC_HAS_TYPE_EXTENDED} 19function ExtendedToDouble(e : pointer) : double; 20var mant : qword; 21 exp : smallint; 22 sign : boolean; 23 d : qword; 24begin 25 move(pbyte(e)[0],mant,8); //mantissa : bytes 0..7 26 move(pbyte(e)[8],exp,2); //exponent and sign: bytes 8..9 27 mant:=LEtoN(mant); 28 exp:=LEtoN(word(exp)); 29 sign:=(exp and $8000)<>0; 30 if sign then exp:=exp and $7FFF; 31 case exp of 32 0 : mant:=0; //if denormalized, value is too small for double, 33 //so it's always zero 34 $7FFF : exp:=2047 //either infinity or NaN 35 else 36 begin 37 dec(exp,16383-1023); 38 if (exp>=-51) and (exp<=0) then //can be denormalized 39 begin 40 mant:=mant shr (-exp); 41 exp:=0; 42 end 43 else 44 if (exp<-51) or (exp>2046) then //exponent too large. 45 begin 46 Result:=0; 47 exit; 48 end 49 else //normalized value 50 mant:=mant shl 1; //hide most significant bit 51 end; 52 end; 53 d:=word(exp); 54 d:=d shl 52; 55 56 mant:=mant shr 12; 57 d:=d or mant; 58 if sign then d:=d or $8000000000000000; 59 Result:=pdouble(@d)^; 60end; 61{$ENDIF} 62{$endif} 63 64function TBinaryObjectReader.ReadWord : word; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 65begin 66 Read(Result,2); 67 Result:=LEtoN(Result); 68end; 69 70function TBinaryObjectReader.ReadDWord : longword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 71begin 72 Read(Result,4); 73 Result:=LEtoN(Result); 74end; 75 76function TBinaryObjectReader.ReadQWord : qword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 77begin 78 Read(Result,8); 79 Result:=LEtoN(Result); 80end; 81 82{$IFDEF FPC_DOUBLE_HILO_SWAPPED} 83procedure SwapDoubleHiLo(var avalue: double); {$ifdef CLASSESINLINE}inline{$endif CLASSESINLINE} 84var dwo1 : dword; 85type tdoublerec = array[0..1] of dword; 86begin 87 dwo1:= tdoublerec(avalue)[0]; 88 tdoublerec(avalue)[0]:=tdoublerec(avalue)[1]; 89 tdoublerec(avalue)[1]:=dwo1; 90end; 91{$ENDIF FPC_DOUBLE_HILO_SWAPPED} 92 93{$ifndef FPUNONE} 94function TBinaryObjectReader.ReadExtended : extended; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 95{$IFNDEF FPC_HAS_TYPE_EXTENDED} 96var ext : array[0..9] of byte; 97{$ENDIF} 98begin 99 {$IFNDEF FPC_HAS_TYPE_EXTENDED} 100 Read(ext[0],10); 101 Result:=ExtendedToDouble(@(ext[0])); 102 {$IFDEF FPC_DOUBLE_HILO_SWAPPED} 103 SwapDoubleHiLo(result); 104 {$ENDIF} 105 {$ELSE} 106 Read(Result,sizeof(Result)); 107 {$ENDIF} 108end; 109{$endif} 110 111constructor TBinaryObjectReader.Create(Stream: TStream; BufSize: Integer); 112begin 113 inherited Create; 114 If (Stream=Nil) then 115 Raise EReadError.Create(SEmptyStreamIllegalReader); 116 FStream := Stream; 117 FBufSize := BufSize; 118 GetMem(FBuffer, BufSize); 119end; 120 121destructor TBinaryObjectReader.Destroy; 122begin 123 { Seek back the amount of bytes that we didn't process until now: } 124 FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), soFromCurrent); 125 126 if Assigned(FBuffer) then 127 FreeMem(FBuffer, FBufSize); 128 129 inherited Destroy; 130end; 131 132function TBinaryObjectReader.ReadValue: TValueType; 133var 134 b: byte; 135begin 136 Read(b, 1); 137 Result := TValueType(b); 138end; 139 140function TBinaryObjectReader.NextValue: TValueType; 141begin 142 Result := ReadValue; 143 { We only 'peek' at the next value, so seek back to unget the read value: } 144 Dec(FBufPos); 145end; 146 147procedure TBinaryObjectReader.BeginRootComponent; 148begin 149 { Read filer signature } 150 ReadSignature; 151end; 152 153procedure TBinaryObjectReader.BeginComponent(var Flags: TFilerFlags; 154 var AChildPos: Integer; var CompClassName, CompName: String); 155var 156 Prefix: Byte; 157 ValueType: TValueType; 158begin 159 { Every component can start with a special prefix: } 160 Flags := []; 161 if (Byte(NextValue) and $f0) = $f0 then 162 begin 163 Prefix := Byte(ReadValue); 164 Flags := TFilerFlags(TFilerFlagsInt(Prefix and $0f)); 165 if ffChildPos in Flags then 166 begin 167 ValueType := ReadValue; 168 case ValueType of 169 vaInt8: 170 AChildPos := ReadInt8; 171 vaInt16: 172 AChildPos := ReadInt16; 173 vaInt32: 174 AChildPos := ReadInt32; 175 else 176 raise EReadError.Create(SInvalidPropertyValue); 177 end; 178 end; 179 end; 180 181 CompClassName := ReadStr; 182 CompName := ReadStr; 183end; 184 185function TBinaryObjectReader.BeginProperty: String; 186begin 187 Result := ReadStr; 188end; 189 190procedure TBinaryObjectReader.ReadBinary(const DestData: TMemoryStream); 191var 192 BinSize: LongInt; 193begin 194 BinSize:=LongInt(ReadDWord); 195 DestData.Size := BinSize; 196 Read(DestData.Memory^, BinSize); 197end; 198 199{$ifndef FPUNONE} 200function TBinaryObjectReader.ReadFloat: Extended; 201begin 202 Result:=ReadExtended; 203end; 204 205function TBinaryObjectReader.ReadSingle: Single; 206var 207 r: record 208 case byte of 209 1: (d: dword); 210 2: (s: single); 211 end; 212begin 213 r.d:=ReadDWord; 214 Result:=r.s; 215end; 216{$endif} 217 218function TBinaryObjectReader.ReadCurrency: Currency; 219var 220 r: record 221 case byte of 222 1: (q: qword); 223 2: (c: currency); 224 end; 225begin 226 r.c:=ReadQWord; 227 Result:=r.c; 228end; 229 230{$ifndef FPUNONE} 231function TBinaryObjectReader.ReadDate: TDateTime; 232var 233 r: record 234 case byte of 235 1: (q: qword); 236 2: (d: TDateTime); 237 end; 238begin 239 r.q:=ReadQWord; 240 Result:=r.d; 241end; 242{$endif} 243 244function TBinaryObjectReader.ReadIdent(ValueType: TValueType): String; 245var 246 i: Byte; 247begin 248 case ValueType of 249 vaIdent: 250 begin 251 Read(i, 1); 252 SetLength(Result, i); 253 Read(Pointer(@Result[1])^, i); 254 end; 255 vaNil: 256 Result := 'nil'; 257 vaFalse: 258 Result := 'False'; 259 vaTrue: 260 Result := 'True'; 261 vaNull: 262 Result := 'Null'; 263 end; 264end; 265 266function TBinaryObjectReader.ReadInt8: ShortInt; 267begin 268 Read(Result, 1); 269end; 270 271function TBinaryObjectReader.ReadInt16: SmallInt; 272begin 273 Result:=SmallInt(ReadWord); 274end; 275 276function TBinaryObjectReader.ReadInt32: LongInt; 277begin 278 Result:=LongInt(ReadDWord); 279end; 280 281function TBinaryObjectReader.ReadInt64: Int64; 282begin 283 Result:=Int64(ReadQWord); 284end; 285 286function TBinaryObjectReader.ReadSet(EnumType: Pointer): Integer; 287type 288{$packset 1} 289 tset = set of 0..(SizeOf(Integer)*8-1); 290{$packset default} 291var 292 Name: String; 293 Value: Integer; 294begin 295 try 296 Result := 0; 297 while True do 298 begin 299 Name := ReadStr; 300 if Length(Name) = 0 then 301 break; 302 Value := GetEnumValue(PTypeInfo(EnumType), Name); 303 if Value = -1 then 304 raise EReadError.Create(SInvalidPropertyValue); 305 include(tset(result),Value); 306 end; 307 except 308 SkipSetBody; 309 raise; 310 end; 311end; 312 313procedure TBinaryObjectReader.ReadSignature; 314var 315 Signature: LongInt; 316begin 317 Read(Signature, 4); 318 if Signature <> LongInt(unaligned(FilerSignature)) then 319 raise EReadError.Create(SInvalidImage); 320end; 321 322function TBinaryObjectReader.ReadStr: String; 323var 324 i: Byte; 325begin 326 Read(i, 1); 327 SetLength(Result, i); 328 if i > 0 then 329 Read(Pointer(@Result[1])^, i); 330end; 331 332function TBinaryObjectReader.ReadString(StringType: TValueType): String; 333var 334 b: Byte; 335 i: Integer; 336begin 337 case StringType of 338 vaLString, vaUTF8String: 339 i:=ReadDWord; 340 else 341 //vaString: 342 begin 343 Read(b, 1); 344 i := b; 345 end; 346 end; 347 SetLength(Result, i); 348 if i > 0 then 349 Read(Pointer(@Result[1])^, i); 350end; 351 352 353function TBinaryObjectReader.ReadWideString: WideString; 354var 355 len: DWord; 356{$IFDEF ENDIAN_BIG} 357 i : integer; 358{$ENDIF} 359begin 360 len := ReadDWord; 361 SetLength(Result, len); 362 if (len > 0) then 363 begin 364 Read(Pointer(@Result[1])^, len*2); 365 {$IFDEF ENDIAN_BIG} 366 for i:=1 to len do 367 Result[i]:=widechar(SwapEndian(word(Result[i]))); 368 {$ENDIF} 369 end; 370end; 371 372function TBinaryObjectReader.ReadUnicodeString: UnicodeString; 373var 374 len: DWord; 375{$IFDEF ENDIAN_BIG} 376 i : integer; 377{$ENDIF} 378begin 379 len := ReadDWord; 380 SetLength(Result, len); 381 if (len > 0) then 382 begin 383 Read(Pointer(@Result[1])^, len*2); 384 {$IFDEF ENDIAN_BIG} 385 for i:=1 to len do 386 Result[i]:=UnicodeChar(SwapEndian(word(Result[i]))); 387 {$ENDIF} 388 end; 389end; 390 391procedure TBinaryObjectReader.SkipComponent(SkipComponentInfos: Boolean); 392var 393 Flags: TFilerFlags; 394 Dummy: Integer; 395 CompClassName, CompName: String; 396begin 397 if SkipComponentInfos then 398 { Skip prefix, component class name and component object name } 399 BeginComponent(Flags, Dummy, CompClassName, CompName); 400 401 { Skip properties } 402 while NextValue <> vaNull do 403 SkipProperty; 404 ReadValue; 405 406 { Skip children } 407 while NextValue <> vaNull do 408 SkipComponent(True); 409 ReadValue; 410end; 411 412procedure TBinaryObjectReader.SkipValue; 413 414 procedure SkipBytes(Count: LongInt); 415 var 416 Dummy: array[0..1023] of Byte; 417 SkipNow: Integer; 418 begin 419 while Count > 0 do 420 begin 421 if Count > 1024 then 422 SkipNow := 1024 423 else 424 SkipNow := Count; 425 Read(Dummy, SkipNow); 426 Dec(Count, SkipNow); 427 end; 428 end; 429 430var 431 Count: LongInt; 432begin 433 case ReadValue of 434 vaNull, vaFalse, vaTrue, vaNil: ; 435 vaList: 436 begin 437 while NextValue <> vaNull do 438 SkipValue; 439 ReadValue; 440 end; 441 vaInt8: 442 SkipBytes(1); 443 vaInt16: 444 SkipBytes(2); 445 vaInt32: 446 SkipBytes(4); 447 vaExtended: 448 SkipBytes(10); 449 vaString, vaIdent: 450 ReadStr; 451 vaBinary, vaLString: 452 begin 453 Count:=LongInt(ReadDWord); 454 SkipBytes(Count); 455 end; 456 vaWString: 457 begin 458 Count:=LongInt(ReadDWord); 459 SkipBytes(Count*sizeof(widechar)); 460 end; 461 vaUString: 462 begin 463 Count:=LongInt(ReadDWord); 464 SkipBytes(Count*sizeof(widechar)); 465 end; 466 vaSet: 467 SkipSetBody; 468 vaCollection: 469 begin 470 while NextValue <> vaNull do 471 begin 472 { Skip the order value if present } 473 if NextValue in [vaInt8, vaInt16, vaInt32] then 474 SkipValue; 475 SkipBytes(1); 476 while NextValue <> vaNull do 477 SkipProperty; 478 ReadValue; 479 end; 480 ReadValue; 481 end; 482 vaSingle: 483{$ifndef FPUNONE} 484 SkipBytes(Sizeof(Single)); 485{$else} 486 SkipBytes(4); 487{$endif} 488 {!!!: vaCurrency: 489 SkipBytes(SizeOf(Currency));} 490 vaDate, vaInt64: 491 SkipBytes(8); 492 end; 493end; 494 495{ private methods } 496 497procedure TBinaryObjectReader.Read(var Buf; Count: LongInt); 498var 499 CopyNow: LongInt; 500 Dest: Pointer; 501begin 502 Dest := @Buf; 503 while Count > 0 do 504 begin 505 if FBufPos >= FBufEnd then 506 begin 507 FBufEnd := FStream.Read(FBuffer^, FBufSize); 508 if FBufEnd = 0 then 509 raise EReadError.Create(SReadError); 510 FBufPos := 0; 511 end; 512 CopyNow := FBufEnd - FBufPos; 513 if CopyNow > Count then 514 CopyNow := Count; 515 Move(PChar(FBuffer)[FBufPos], Dest^, CopyNow); 516 Inc(FBufPos, CopyNow); 517 Inc(Dest, CopyNow); 518 Dec(Count, CopyNow); 519 end; 520end; 521 522procedure TBinaryObjectReader.SkipProperty; 523begin 524 { Skip property name, then the property value } 525 ReadStr; 526 SkipValue; 527end; 528 529procedure TBinaryObjectReader.SkipSetBody; 530begin 531 while Length(ReadStr) > 0 do; 532end; 533 534 535 536{****************************************************************************} 537{* TREADER *} 538{****************************************************************************} 539 540type 541 TFieldInfo = packed record 542 FieldOffset: LongWord; 543 ClassTypeIndex: Word; 544 Name: ShortString; 545 end; 546 547{$ifdef VER3_0} 548 PersistentClassRef = TPersistentClass; 549{$else VER3_0} 550 PPersistentClass = ^TPersistentClass; 551 PersistentClassRef = PPersistentClass; 552{$endif VER3_0} 553 554 PFieldClassTable = ^TFieldClassTable; 555 TFieldClassTable = 556{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} 557 packed 558{$endif FPC_REQUIRES_PROPER_ALIGNMENT} 559 record 560 Count: Word; 561 Entries: array[{$ifdef cpu16}0..16384 div sizeof(PersistentClassRef){$else}Word{$endif}] of PersistentClassRef; 562 end; 563 564 PFieldTable = ^TFieldTable; 565 TFieldTable = 566{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} 567 packed 568{$endif FPC_REQUIRES_PROPER_ALIGNMENT} 569 record 570 FieldCount: Word; 571 ClassTable: PFieldClassTable; 572 // Fields: array[Word] of TFieldInfo; Elements have variant size! 573 end; 574 575function GetFieldClass(Instance: TObject; const ClassName: string): TPersistentClass; 576var 577 ShortClassName: shortstring; 578 ClassType: TClass; 579 ClassTable: PFieldClassTable; 580 i: Integer; 581 FieldTable: PFieldTable; 582begin 583 // At first, try to locate the class in the class tables 584 ShortClassName := ClassName; 585 ClassType := Instance.ClassType; 586 while ClassType <> TPersistent do 587 begin 588 FieldTable := PFieldTable(PVmt(ClassType)^.vFieldTable); 589 if Assigned(FieldTable) then 590 begin 591 ClassTable := FieldTable^.ClassTable; 592 for i := 0 to ClassTable^.Count - 1 do 593 begin 594 Result := ClassTable^.Entries[i]{$ifndef VER3_0}^{$endif}; 595 if Result.ClassNameIs(ShortClassName) then 596 exit; 597 end; 598 end; 599 // Try again with the parent class type 600 ClassType := ClassType.ClassParent; 601 end; 602 Result := Classes.GetClass(ClassName); 603end; 604 605 606constructor TReader.Create(Stream: TStream; BufSize: Integer); 607begin 608 inherited Create; 609 If (Stream=Nil) then 610 Raise EReadError.Create(SEmptyStreamIllegalReader); 611 FDriver := CreateDriver(Stream, BufSize); 612{$ifdef FPC_HAS_FEATURE_THREADING} 613 InitCriticalSection(FLock); 614{$ENDIF} 615end; 616 617destructor TReader.Destroy; 618begin 619{$ifdef FPC_HAS_FEATURE_THREADING} 620 DoneCriticalSection(FLock); 621{$ENDIF} 622 FDriver.Free; 623 inherited Destroy; 624end; 625 626procedure TReader.Lock; 627begin 628{$ifdef FPC_HAS_FEATURE_THREADING} 629 EnterCriticalSection(FLock); 630{$ENDIF} 631end; 632 633procedure TReader.Unlock; 634begin 635{$ifdef FPC_HAS_FEATURE_THREADING} 636 LeaveCriticalSection(FLock); 637{$ENDIF} 638end; 639 640procedure TReader.FlushBuffer; 641begin 642 Driver.FlushBuffer; 643end; 644 645function TReader.CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectReader; 646begin 647 Result := TBinaryObjectReader.Create(Stream, BufSize); 648end; 649 650procedure TReader.BeginReferences; 651begin 652 FLoaded := TFpList.Create; 653end; 654 655procedure TReader.CheckValue(Value: TValueType); 656begin 657 if FDriver.NextValue <> Value then 658 raise EReadError.Create(SInvalidPropertyValue) 659 else 660 FDriver.ReadValue; 661end; 662 663procedure TReader.DefineProperty(const Name: String; AReadData: TReaderProc; 664 WriteData: TWriterProc; HasData: Boolean); 665begin 666 if Assigned(AReadData) and (UpperCase(Name) = UpperCase(FPropName)) then 667 begin 668 AReadData(Self); 669 SetLength(FPropName, 0); 670 end; 671end; 672 673procedure TReader.DefineBinaryProperty(const Name: String; 674 AReadData, WriteData: TStreamProc; HasData: Boolean); 675var 676 MemBuffer: TMemoryStream; 677begin 678 if Assigned(AReadData) and (UpperCase(Name) = UpperCase(FPropName)) then 679 begin 680 { Check if the next property really is a binary property} 681 if FDriver.NextValue <> vaBinary then 682 begin 683 FDriver.SkipValue; 684 FCanHandleExcepts := True; 685 raise EReadError.Create(SInvalidPropertyValue); 686 end else 687 FDriver.ReadValue; 688 689 MemBuffer := TMemoryStream.Create; 690 try 691 FDriver.ReadBinary(MemBuffer); 692 FCanHandleExcepts := True; 693 AReadData(MemBuffer); 694 finally 695 MemBuffer.Free; 696 end; 697 SetLength(FPropName, 0); 698 end; 699end; 700 701function TReader.EndOfList: Boolean; 702begin 703 Result := FDriver.NextValue = vaNull; 704end; 705 706procedure TReader.EndReferences; 707begin 708 FLoaded.Free; 709 FLoaded := nil; 710end; 711 712function TReader.Error(const Message: String): Boolean; 713begin 714 Result := False; 715 if Assigned(FOnError) then 716 FOnError(Self, Message, Result); 717end; 718 719function TReader.FindMethod(ARoot: TComponent; const AMethodName: String): CodePointer; 720var 721 ErrorResult: Boolean; 722begin 723 Result := ARoot.MethodAddress(AMethodName); 724 ErrorResult := Result = nil; 725 726 { always give the OnFindMethod callback a chance to locate the method } 727 if Assigned(FOnFindMethod) then 728 FOnFindMethod(Self, AMethodName, Result, ErrorResult); 729 730 if ErrorResult then 731 raise EReadError.Create(SInvalidPropertyValue); 732end; 733 734procedure TReader.DoFixupReferences; 735 736Var 737 R,RN : TLocalUnresolvedReference; 738 G : TUnresolvedInstance; 739 Ref : String; 740 C : TComponent; 741 P : integer; 742 L : TLinkedList; 743 RI: Pointer; // raw interface 744 IIDStr: ShortString; 745 746begin 747 If Assigned(FFixups) then 748 begin 749 L:=TLinkedList(FFixups); 750 R:=TLocalUnresolvedReference(L.Root); 751 While (R<>Nil) do 752 begin 753 RN:=TLocalUnresolvedReference(R.Next); 754 Ref:=R.FRelative; 755 If Assigned(FOnReferenceName) then 756 FOnReferenceName(Self,Ref); 757 C:=FindNestedComponent(R.FRoot,Ref); 758 If Assigned(C) then 759 if R.FPropInfo^.PropType^.Kind = tkInterface then 760 SetInterfaceProp(R.FInstance,R.FPropInfo,C) 761 else if R.FPropInfo^.PropType^.Kind = tkInterfaceRaw then 762 begin 763 IIDStr := GetTypeData(R.FPropInfo^.PropType)^.IIDStr; 764 if IIDStr = '' then 765 raise EReadError.CreateFmt(SInterfaceNoIIDStr, [R.FPropInfo^.PropType^.Name]); 766 if C.GetInterface(IIDStr, RI) then 767 SetRawInterfaceProp(R.FInstance,R.FPropInfo,RI) 768 else 769 raise EReadError.CreateFmt(SComponentDoesntImplement, [C.ClassName, IIDStr]); 770 end 771 else 772 SetObjectProp(R.FInstance,R.FPropInfo,C) 773 else 774 begin 775 P:=Pos('.',R.FRelative); 776 If (P<>0) then 777 begin 778 G:=AddToResolveList(R.FInstance); 779 G.Addreference(R.FRoot,R.FPropInfo,Copy(R.FRelative,1,P-1),Copy(R.FRelative,P+1,Length(R.FRelative)-P)); 780 end; 781 end; 782 L.RemoveItem(R,True); 783 R:=RN; 784 end; 785 FreeAndNil(FFixups); 786 end; 787end; 788 789procedure TReader.FixupReferences; 790var 791 i: Integer; 792begin 793 DoFixupReferences; 794 GlobalFixupReferences; 795 for i := 0 to FLoaded.Count - 1 do 796 TComponent(FLoaded[I]).Loaded; 797end; 798 799 800function TReader.NextValue: TValueType; 801begin 802 Result := FDriver.NextValue; 803end; 804 805procedure TReader.Read(var Buf; Count: LongInt); 806begin 807 //This should give an exception if read is not implemented (i.e. TTextObjectReader) 808 //but should work with TBinaryObjectReader. 809 Driver.Read(Buf, Count); 810end; 811 812procedure TReader.PropertyError; 813begin 814 FDriver.SkipValue; 815 raise EReadError.CreateFmt(SUnknownProperty,[FPropName]); 816end; 817 818function TReader.ReadBoolean: Boolean; 819var 820 ValueType: TValueType; 821begin 822 ValueType := FDriver.ReadValue; 823 if ValueType = vaTrue then 824 Result := True 825 else if ValueType = vaFalse then 826 Result := False 827 else 828 raise EReadError.Create(SInvalidPropertyValue); 829end; 830 831function TReader.ReadChar: Char; 832var 833 s: String; 834begin 835 s := ReadString; 836 if Length(s) = 1 then 837 Result := s[1] 838 else 839 raise EReadError.Create(SInvalidPropertyValue); 840end; 841 842function TReader.ReadWideChar: WideChar; 843 844var 845 W: WideString; 846 847begin 848 W := ReadWideString; 849 if Length(W) = 1 then 850 Result := W[1] 851 else 852 raise EReadError.Create(SInvalidPropertyValue); 853end; 854 855function TReader.ReadUnicodeChar: UnicodeChar; 856 857var 858 U: UnicodeString; 859 860begin 861 U := ReadUnicodeString; 862 if Length(U) = 1 then 863 Result := U[1] 864 else 865 raise EReadError.Create(SInvalidPropertyValue); 866end; 867 868procedure TReader.ReadCollection(Collection: TCollection); 869var 870 Item: TCollectionItem; 871begin 872 Collection.BeginUpdate; 873 if not EndOfList then 874 Collection.Clear; 875 while not EndOfList do begin 876 ReadListBegin; 877 Item := Collection.Add; 878 while NextValue<>vaNull do 879 ReadProperty(Item); 880 ReadListEnd; 881 end; 882 Collection.EndUpdate; 883 ReadListEnd; 884end; 885 886function TReader.ReadComponent(Component: TComponent): TComponent; 887var 888 Flags: TFilerFlags; 889 890 function Recover(var aComponent: TComponent): Boolean; 891 begin 892 Result := False; 893 if ExceptObject.InheritsFrom(Exception) then 894 begin 895 if not ((ffInherited in Flags) or Assigned(Component)) then 896 aComponent.Free; 897 aComponent := nil; 898 FDriver.SkipComponent(False); 899 Result := Error(Exception(ExceptObject).Message); 900 end; 901 end; 902 903var 904 CompClassName, Name: String; 905 n, ChildPos: Integer; 906 SavedParent, SavedLookupRoot: TComponent; 907 ComponentClass: TComponentClass; 908 C, NewComponent: TComponent; 909 SubComponents: TList; 910begin 911 FDriver.BeginComponent(Flags, ChildPos, CompClassName, Name); 912 SavedParent := Parent; 913 SavedLookupRoot := FLookupRoot; 914 SubComponents := nil; 915 try 916 Result := Component; 917 if not Assigned(Result) then 918 try 919 if ffInherited in Flags then 920 begin 921 { Try to locate the existing ancestor component } 922 923 if Assigned(FLookupRoot) then 924 Result := FLookupRoot.FindComponent(Name) 925 else 926 Result := nil; 927 928 if not Assigned(Result) then 929 begin 930 if Assigned(FOnAncestorNotFound) then 931 FOnAncestorNotFound(Self, Name, 932 FindComponentClass(CompClassName), Result); 933 if not Assigned(Result) then 934 raise EReadError.CreateFmt(SAncestorNotFound, [Name]); 935 end; 936 937 Parent := Result.GetParentComponent; 938 if not Assigned(Parent) then 939 Parent := Root; 940 end else 941 begin 942 Result := nil; 943 ComponentClass := FindComponentClass(CompClassName); 944 if Assigned(FOnCreateComponent) then 945 FOnCreateComponent(Self, ComponentClass, Result); 946 if not Assigned(Result) then 947 begin 948 NewComponent := TComponent(ComponentClass.NewInstance); 949 if ffInline in Flags then 950 NewComponent.FComponentState := 951 NewComponent.FComponentState + [csLoading, csInline]; 952 NewComponent.Create(Owner); 953 954 { Don't set Result earlier because else we would come in trouble 955 with the exception recover mechanism! (Result should be NIL if 956 an error occurred) } 957 Result := NewComponent; 958 end; 959 Include(Result.FComponentState, csLoading); 960 end; 961 except 962 if not Recover(Result) then 963 raise; 964 end; 965 966 if Assigned(Result) then 967 try 968 Include(Result.FComponentState, csLoading); 969 970 { create list of subcomponents and set loading} 971 SubComponents := TList.Create; 972 for n := 0 to Result.ComponentCount - 1 do 973 begin 974 C := Result.Components[n]; 975 if csSubcomponent in C.ComponentStyle 976 then begin 977 SubComponents.Add(C); 978 Include(C.FComponentState, csLoading); 979 end; 980 end; 981 982 if not (ffInherited in Flags) then 983 try 984 Result.SetParentComponent(Parent); 985 if Assigned(FOnSetName) then 986 FOnSetName(Self, Result, Name); 987 Result.Name := Name; 988 if FindGlobalComponent(Name) = Result then 989 Include(Result.FComponentState, csInline); 990 except 991 if not Recover(Result) then 992 raise; 993 end; 994 if not Assigned(Result) then 995 exit; 996 if csInline in Result.ComponentState then 997 FLookupRoot := Result; 998 999 { Read the component state } 1000 Include(Result.FComponentState, csReading); 1001 for n := 0 to Subcomponents.Count - 1 do 1002 Include(TComponent(Subcomponents[n]).FComponentState, csReading); 1003 1004 Result.ReadState(Self); 1005 1006 Exclude(Result.FComponentState, csReading); 1007 for n := 0 to Subcomponents.Count - 1 do 1008 Exclude(TComponent(Subcomponents[n]).FComponentState, csReading); 1009 1010 if ffChildPos in Flags then 1011 Parent.SetChildOrder(Result, ChildPos); 1012 1013 { Add component to list of loaded components, if necessary } 1014 if (not ((ffInherited in Flags) or (csInline in Result.ComponentState))) or 1015 (FLoaded.IndexOf(Result) < 0) 1016 then begin 1017 for n := 0 to Subcomponents.Count - 1 do 1018 FLoaded.Add(Subcomponents[n]); 1019 FLoaded.Add(Result); 1020 end; 1021 except 1022 if ((ffInherited in Flags) or Assigned(Component)) then 1023 Result.Free; 1024 raise; 1025 end; 1026 finally 1027 Parent := SavedParent; 1028 FLookupRoot := SavedLookupRoot; 1029 Subcomponents.Free; 1030 end; 1031end; 1032 1033procedure TReader.ReadData(Instance: TComponent); 1034var 1035 SavedOwner, SavedParent: TComponent; 1036 1037begin 1038 { Read properties } 1039 while not EndOfList do 1040 ReadProperty(Instance); 1041 ReadListEnd; 1042 1043 { Read children } 1044 SavedOwner := Owner; 1045 SavedParent := Parent; 1046 try 1047 Owner := Instance.GetChildOwner; 1048 if not Assigned(Owner) then 1049 Owner := Root; 1050 Parent := Instance.GetChildParent; 1051 1052 while not EndOfList do 1053 ReadComponent(nil); 1054 ReadListEnd; 1055 finally 1056 Owner := SavedOwner; 1057 Parent := SavedParent; 1058 end; 1059 1060 { Fixup references if necessary (normally only if this is the root) } 1061 If (Instance=FRoot) then 1062 DoFixupReferences; 1063end; 1064 1065{$ifndef FPUNONE} 1066function TReader.ReadFloat: Extended; 1067begin 1068 if FDriver.NextValue = vaExtended then 1069 begin 1070 ReadValue; 1071 Result := FDriver.ReadFloat 1072 end else 1073 Result := ReadInt64; 1074end; 1075 1076procedure TReader.ReadSignature; 1077begin 1078 FDriver.ReadSignature; 1079end; 1080 1081function TReader.ReadSingle: Single; 1082begin 1083 if FDriver.NextValue = vaSingle then 1084 begin 1085 FDriver.ReadValue; 1086 Result := FDriver.ReadSingle; 1087 end else 1088 Result := ReadInteger; 1089end; 1090{$endif} 1091 1092function TReader.ReadCurrency: Currency; 1093begin 1094 if FDriver.NextValue = vaCurrency then 1095 begin 1096 FDriver.ReadValue; 1097 Result := FDriver.ReadCurrency; 1098 end else 1099 Result := ReadInteger; 1100end; 1101 1102{$ifndef FPUNONE} 1103function TReader.ReadDate: TDateTime; 1104begin 1105 if FDriver.NextValue = vaDate then 1106 begin 1107 FDriver.ReadValue; 1108 Result := FDriver.ReadDate; 1109 end else 1110 Result := ReadInteger; 1111end; 1112{$endif} 1113 1114function TReader.ReadIdent: String; 1115var 1116 ValueType: TValueType; 1117begin 1118 ValueType := FDriver.ReadValue; 1119 if ValueType in [vaIdent, vaNil, vaFalse, vaTrue, vaNull] then 1120 Result := FDriver.ReadIdent(ValueType) 1121 else 1122 raise EReadError.Create(SInvalidPropertyValue); 1123end; 1124 1125 1126function TReader.ReadInteger: LongInt; 1127begin 1128 case FDriver.ReadValue of 1129 vaInt8: 1130 Result := FDriver.ReadInt8; 1131 vaInt16: 1132 Result := FDriver.ReadInt16; 1133 vaInt32: 1134 Result := FDriver.ReadInt32; 1135 else 1136 raise EReadError.Create(SInvalidPropertyValue); 1137 end; 1138end; 1139 1140function TReader.ReadInt64: Int64; 1141begin 1142 if FDriver.NextValue = vaInt64 then 1143 begin 1144 FDriver.ReadValue; 1145 Result := FDriver.ReadInt64; 1146 end else 1147 Result := ReadInteger; 1148end; 1149 1150function TReader.ReadSet(EnumType: Pointer): Integer; 1151begin 1152 if FDriver.NextValue = vaSet then 1153 begin 1154 FDriver.ReadValue; 1155 Result := FDriver.ReadSet(enumtype); 1156 end 1157 else 1158 Result := ReadInteger; 1159end; 1160 1161procedure TReader.ReadListBegin; 1162begin 1163 CheckValue(vaList); 1164end; 1165 1166procedure TReader.ReadListEnd; 1167begin 1168 CheckValue(vaNull); 1169end; 1170 1171function TReader.ReadVariant: variant; 1172var 1173 nv: TValueType; 1174begin 1175 { Ensure that a Variant manager is installed } 1176 if not Assigned(VarClearProc) then 1177 raise EReadError.Create(SErrNoVariantSupport); 1178 1179 FillChar(Result,sizeof(Result),0); 1180 1181 nv:=NextValue; 1182 case nv of 1183 vaNil: 1184 begin 1185 Result:=system.unassigned; 1186 readvalue; 1187 end; 1188 vaNull: 1189 begin 1190 Result:=system.null; 1191 readvalue; 1192 end; 1193 { all integer sizes must be split for big endian systems } 1194 vaInt8,vaInt16,vaInt32: 1195 begin 1196 Result:=ReadInteger; 1197 end; 1198 vaInt64: 1199 begin 1200 Result:=ReadInt64; 1201 end; 1202 vaQWord: 1203 begin 1204 Result:=QWord(ReadInt64); 1205 end; 1206 vaFalse,vaTrue: 1207 begin 1208 Result:=(nv<>vaFalse); 1209 readValue; 1210 end; 1211 vaCurrency: 1212 begin 1213 Result:=ReadCurrency; 1214 end; 1215{$ifndef fpunone} 1216 vaSingle: 1217 begin 1218 Result:=ReadSingle; 1219 end; 1220 vaExtended: 1221 begin 1222 Result:=ReadFloat; 1223 end; 1224 vaDate: 1225 begin 1226 Result:=ReadDate; 1227 end; 1228{$endif fpunone} 1229 vaWString,vaUTF8String: 1230 begin 1231 Result:=ReadWideString; 1232 end; 1233 vaString: 1234 begin 1235 Result:=ReadString; 1236 end; 1237 vaUString: 1238 begin 1239 Result:=ReadUnicodeString; 1240 end; 1241 else 1242 raise EReadError.CreateFmt(SUnsupportedPropertyVariantType, [Ord(nv)]); 1243 end; 1244end; 1245 1246procedure TReader.ReadProperty(AInstance: TPersistent); 1247var 1248 Path: String; 1249 Instance: TPersistent; 1250 DotPos, NextPos: PChar; 1251 PropInfo: PPropInfo; 1252 Obj: TObject; 1253 Name: String; 1254 Skip: Boolean; 1255 Handled: Boolean; 1256 OldPropName: String; 1257 1258 function HandleMissingProperty(IsPath: Boolean): boolean; 1259 begin 1260 Result:=true; 1261 if Assigned(OnPropertyNotFound) then begin 1262 // user defined property error handling 1263 OldPropName:=FPropName; 1264 Handled:=false; 1265 Skip:=false; 1266 OnPropertyNotFound(Self,Instance,FPropName,IsPath,Handled,Skip); 1267 if Handled and (not Skip) and (OldPropName<>FPropName) then 1268 // try alias property 1269 PropInfo := GetPropInfo(Instance.ClassInfo, FPropName); 1270 if Skip then begin 1271 FDriver.SkipValue; 1272 Result:=false; 1273 exit; 1274 end; 1275 end; 1276 end; 1277 1278begin 1279 try 1280 Path := FDriver.BeginProperty; 1281 try 1282 Instance := AInstance; 1283 FCanHandleExcepts := True; 1284 DotPos := PChar(Path); 1285 while True do 1286 begin 1287 NextPos := StrScan(DotPos, '.'); 1288 if Assigned(NextPos) then 1289 FPropName := Copy(String(DotPos), 1, Integer(NextPos - DotPos)) 1290 else 1291 begin 1292 FPropName := DotPos; 1293 break; 1294 end; 1295 DotPos := NextPos + 1; 1296 1297 PropInfo := GetPropInfo(Instance.ClassInfo, FPropName); 1298 if not Assigned(PropInfo) then begin 1299 if not HandleMissingProperty(true) then exit; 1300 if not Assigned(PropInfo) then 1301 PropertyError; 1302 end; 1303 1304 if PropInfo^.PropType^.Kind = tkClass then 1305 Obj := TObject(GetObjectProp(Instance, PropInfo)) 1306 //else if PropInfo^.PropType^.Kind = tkInterface then 1307 // Obj := TObject(GetInterfaceProp(Instance, PropInfo)) 1308 else 1309 Obj := nil; 1310 1311 if not (Obj is TPersistent) then 1312 begin 1313 { All path elements must be persistent objects! } 1314 FDriver.SkipValue; 1315 raise EReadError.Create(SInvalidPropertyPath); 1316 end; 1317 Instance := TPersistent(Obj); 1318 end; 1319 1320 PropInfo := GetPropInfo(Instance.ClassInfo, FPropName); 1321 if Assigned(PropInfo) then 1322 ReadPropValue(Instance, PropInfo) 1323 else 1324 begin 1325 FCanHandleExcepts := False; 1326 Instance.DefineProperties(Self); 1327 FCanHandleExcepts := True; 1328 if Length(FPropName) > 0 then begin 1329 if not HandleMissingProperty(false) then exit; 1330 if not Assigned(PropInfo) then 1331 PropertyError; 1332 end; 1333 end; 1334 except 1335 on e: Exception do 1336 begin 1337 SetLength(Name, 0); 1338 if AInstance.InheritsFrom(TComponent) then 1339 Name := TComponent(AInstance).Name; 1340 if Length(Name) = 0 then 1341 Name := AInstance.ClassName; 1342 raise EReadError.CreateFmt(SPropertyException, 1343 [Name, DotSep, Path, e.Message]); 1344 end; 1345 end; 1346 except 1347 on e: Exception do 1348 if not FCanHandleExcepts or not Error(E.Message) then 1349 raise; 1350 end; 1351end; 1352 1353procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: Pointer); 1354const 1355 NullMethod: TMethod = (Code: nil; Data: nil); 1356var 1357 PropType: PTypeInfo; 1358 Value: LongInt; 1359{ IdentToIntFn: TIdentToInt; } 1360 Ident: String; 1361 Method: TMethod; 1362 Handled: Boolean; 1363 TmpStr: String; 1364begin 1365 if not Assigned(PPropInfo(PropInfo)^.SetProc) then 1366 raise EReadError.Create(SReadOnlyProperty); 1367 1368 PropType := PPropInfo(PropInfo)^.PropType; 1369 case PropType^.Kind of 1370 tkInteger: 1371 if FDriver.NextValue = vaIdent then 1372 begin 1373 Ident := ReadIdent; 1374 if GlobalIdentToInt(Ident,Value) then 1375 SetOrdProp(Instance, PropInfo, Value) 1376 else 1377 raise EReadError.Create(SInvalidPropertyValue); 1378 end else 1379 SetOrdProp(Instance, PropInfo, ReadInteger); 1380 tkBool: 1381 SetOrdProp(Instance, PropInfo, Ord(ReadBoolean)); 1382 tkChar: 1383 SetOrdProp(Instance, PropInfo, Ord(ReadChar)); 1384 tkWChar,tkUChar: 1385 SetOrdProp(Instance, PropInfo, Ord(ReadWideChar)); 1386 tkEnumeration: 1387 begin 1388 Value := GetEnumValue(PropType, ReadIdent); 1389 if Value = -1 then 1390 raise EReadError.Create(SInvalidPropertyValue); 1391 SetOrdProp(Instance, PropInfo, Value); 1392 end; 1393{$ifndef FPUNONE} 1394 tkFloat: 1395 SetFloatProp(Instance, PropInfo, ReadFloat); 1396{$endif} 1397 tkSet: 1398 begin 1399 CheckValue(vaSet); 1400 SetOrdProp(Instance, PropInfo, 1401 FDriver.ReadSet(GetTypeData(PropType)^.CompType)); 1402 end; 1403 tkMethod: 1404 if FDriver.NextValue = vaNil then 1405 begin 1406 FDriver.ReadValue; 1407 SetMethodProp(Instance, PropInfo, NullMethod); 1408 end else 1409 begin 1410 Handled:=false; 1411 Ident:=ReadIdent; 1412 if Assigned(OnSetMethodProperty) then 1413 OnSetMethodProperty(Self,Instance,PPropInfo(PropInfo),Ident, 1414 Handled); 1415 if not Handled then begin 1416 Method.Code := FindMethod(Root, Ident); 1417 Method.Data := Root; 1418 if Assigned(Method.Code) then 1419 SetMethodProp(Instance, PropInfo, Method); 1420 end; 1421 end; 1422 tkSString, tkLString, tkAString: 1423 begin 1424 TmpStr:=ReadString; 1425 if Assigned(FOnReadStringProperty) then 1426 FOnReadStringProperty(Self,Instance,PropInfo,TmpStr); 1427 SetStrProp(Instance, PropInfo, TmpStr); 1428 end; 1429 tkUstring: 1430 SetUnicodeStrProp(Instance,PropInfo,ReadUnicodeString); 1431 tkWString: 1432 SetWideStrProp(Instance,PropInfo,ReadWideString); 1433 tkVariant: 1434 begin 1435 SetVariantProp(Instance,PropInfo,ReadVariant); 1436 end; 1437 tkClass, tkInterface, tkInterfaceRaw: 1438 case FDriver.NextValue of 1439 vaNil: 1440 begin 1441 FDriver.ReadValue; 1442 SetOrdProp(Instance, PropInfo, 0) 1443 end; 1444 vaCollection: 1445 begin 1446 FDriver.ReadValue; 1447 ReadCollection(TCollection(GetObjectProp(Instance, PropInfo))); 1448 end 1449 else 1450 begin 1451 If Not Assigned(FFixups) then 1452 FFixups:=TLinkedList.Create(TLocalUnresolvedReference); 1453 With TLocalUnresolvedReference(TLinkedList(FFixups).Add) do 1454 begin 1455 FInstance:=Instance; 1456 FRoot:=Root; 1457 FPropInfo:=PropInfo; 1458 FRelative:=ReadIdent; 1459 end; 1460 end; 1461 end; 1462 tkInt64, tkQWord: SetInt64Prop(Instance, PropInfo, ReadInt64); 1463 else 1464 raise EReadError.CreateFmt(SUnknownPropertyType, [Ord(PropType^.Kind)]); 1465 end; 1466end; 1467 1468function TReader.ReadRootComponent(ARoot: TComponent): TComponent; 1469var 1470 Dummy, i: Integer; 1471 Flags: TFilerFlags; 1472 CompClassName, CompName, ResultName: String; 1473begin 1474 FDriver.BeginRootComponent; 1475 Result := nil; 1476 {!!!: GlobalNameSpace.BeginWrite; // Loading from stream adds to name space 1477 try} 1478 try 1479 FDriver.BeginComponent(Flags, Dummy, CompClassName, CompName); 1480 if not Assigned(ARoot) then 1481 begin 1482 { Read the class name and the object name and create a new object: } 1483 Result := TComponentClass(FindClass(CompClassName)).Create(nil); 1484 Result.Name := CompName; 1485 end else 1486 begin 1487 Result := ARoot; 1488 1489 if not (csDesigning in Result.ComponentState) then 1490 begin 1491 Result.FComponentState := 1492 Result.FComponentState + [csLoading, csReading]; 1493 1494 { We need an unique name } 1495 i := 0; 1496 { Don't use Result.Name directly, as this would influence 1497 FindGlobalComponent in successive loop runs } 1498 ResultName := CompName; 1499 Lock; 1500 try 1501 while Assigned(FindGlobalComponent(ResultName)) do 1502 begin 1503 Inc(i); 1504 ResultName := CompName + '_' + IntToStr(i); 1505 end; 1506 Result.Name := ResultName; 1507 finally 1508 Unlock; 1509 end; 1510 end; 1511 end; 1512 1513 FRoot := Result; 1514 FLookupRoot := Result; 1515 if Assigned(GlobalLoaded) then 1516 FLoaded := GlobalLoaded 1517 else 1518 FLoaded := TFpList.Create; 1519 1520 try 1521 if FLoaded.IndexOf(FRoot) < 0 then 1522 FLoaded.Add(FRoot); 1523 FOwner := FRoot; 1524 FRoot.FComponentState := FRoot.FComponentState + [csLoading, csReading]; 1525 FRoot.ReadState(Self); 1526 Exclude(FRoot.FComponentState, csReading); 1527 1528 if not Assigned(GlobalLoaded) then 1529 for i := 0 to FLoaded.Count - 1 do 1530 TComponent(FLoaded[i]).Loaded; 1531 1532 finally 1533 if not Assigned(GlobalLoaded) then 1534 FLoaded.Free; 1535 FLoaded := nil; 1536 end; 1537 GlobalFixupReferences; 1538 except 1539 RemoveFixupReferences(ARoot, ''); 1540 if not Assigned(ARoot) then 1541 Result.Free; 1542 raise; 1543 end; 1544 {finally 1545 GlobalNameSpace.EndWrite; 1546 end;} 1547end; 1548 1549procedure TReader.ReadComponents(AOwner, AParent: TComponent; 1550 Proc: TReadComponentsProc); 1551var 1552 Component: TComponent; 1553begin 1554 Root := AOwner; 1555 Owner := AOwner; 1556 Parent := AParent; 1557 BeginReferences; 1558 try 1559 while not EndOfList do 1560 begin 1561 FDriver.BeginRootComponent; 1562 Component := ReadComponent(nil); 1563 if Assigned(Proc) then 1564 Proc(Component); 1565 end; 1566 ReadListEnd; 1567 FixupReferences; 1568 finally 1569 EndReferences; 1570 end; 1571end; 1572 1573 1574function TReader.ReadString: String; 1575var 1576 StringType: TValueType; 1577begin 1578 StringType := FDriver.ReadValue; 1579 if StringType in [vaString, vaLString,vaUTF8String] then 1580 begin 1581 Result := FDriver.ReadString(StringType); 1582 if (StringType=vaUTF8String) then 1583 Result:=string(utf8Decode(Result)); 1584 end 1585 else if StringType in [vaWString] then 1586 Result:= string(FDriver.ReadWidestring) 1587 else if StringType in [vaUString] then 1588 Result:= string(FDriver.ReadUnicodeString) 1589 else 1590 raise EReadError.Create(SInvalidPropertyValue); 1591end; 1592 1593 1594function TReader.ReadWideString: WideString; 1595var 1596 s: String; 1597 i: Integer; 1598 vt:TValueType; 1599begin 1600 if NextValue in [vaWString,vaUString,vaUTF8String] then 1601 //vaUTF8String needs conversion? 2008-09-06 mse, YES!! AntonK 1602 begin 1603 vt:=ReadValue; 1604 if vt=vaUTF8String then 1605 Result := utf8decode(fDriver.ReadString(vaLString)) 1606 else 1607 Result := FDriver.ReadWideString 1608 end 1609 else 1610 begin 1611 //data probable from ObjectTextToBinary 1612 s := ReadString; 1613 setlength(result,length(s)); 1614 for i:= 1 to length(s) do begin 1615 result[i]:= widechar(ord(s[i])); //no code conversion 1616 end; 1617 end; 1618end; 1619 1620 1621function TReader.ReadUnicodeString: UnicodeString; 1622var 1623 s: String; 1624 i: Integer; 1625 vt:TValueType; 1626begin 1627 if NextValue in [vaWString,vaUString,vaUTF8String] then 1628 //vaUTF8String needs conversion? 2008-09-06 mse, YES!! AntonK 1629 begin 1630 vt:=ReadValue; 1631 if vt=vaUTF8String then 1632 Result := utf8decode(fDriver.ReadString(vaLString)) 1633 else 1634 Result := FDriver.ReadWideString 1635 end 1636 else 1637 begin 1638 //data probable from ObjectTextToBinary 1639 s := ReadString; 1640 setlength(result,length(s)); 1641 for i:= 1 to length(s) do begin 1642 result[i]:= UnicodeChar(ord(s[i])); //no code conversion 1643 end; 1644 end; 1645end; 1646 1647 1648function TReader.ReadValue: TValueType; 1649begin 1650 Result := FDriver.ReadValue; 1651end; 1652 1653procedure TReader.CopyValue(Writer: TWriter); 1654 1655 procedure CopyBytes(Count: Integer); 1656{ var 1657 Buffer: array[0..1023] of Byte; } 1658 begin 1659{!!!: while Count > 1024 do 1660 begin 1661 FDriver.Read(Buffer, 1024); 1662 Writer.Driver.Write(Buffer, 1024); 1663 Dec(Count, 1024); 1664 end; 1665 if Count > 0 then 1666 begin 1667 FDriver.Read(Buffer, Count); 1668 Writer.Driver.Write(Buffer, Count); 1669 end;} 1670 end; 1671 1672{var 1673 s: String; 1674 Count: LongInt; } 1675begin 1676 case FDriver.NextValue of 1677 vaNull: 1678 Writer.WriteIdent('NULL'); 1679 vaFalse: 1680 Writer.WriteIdent('FALSE'); 1681 vaTrue: 1682 Writer.WriteIdent('TRUE'); 1683 vaNil: 1684 Writer.WriteIdent('NIL'); 1685 {!!!: vaList, vaCollection: 1686 begin 1687 Writer.WriteValue(FDriver.ReadValue); 1688 while not EndOfList do 1689 CopyValue(Writer); 1690 ReadListEnd; 1691 Writer.WriteListEnd; 1692 end;} 1693 vaInt8, vaInt16, vaInt32: 1694 Writer.WriteInteger(ReadInteger); 1695{$ifndef FPUNONE} 1696 vaExtended: 1697 Writer.WriteFloat(ReadFloat); 1698{$endif} 1699 {!!!: vaString: 1700 Writer.WriteStr(ReadStr);} 1701 vaIdent: 1702 Writer.WriteIdent(ReadIdent); 1703 {!!!: vaBinary, vaLString, vaWString: 1704 begin 1705 Writer.WriteValue(FDriver.ReadValue); 1706 FDriver.Read(Count, SizeOf(Count)); 1707 Writer.Driver.Write(Count, SizeOf(Count)); 1708 CopyBytes(Count); 1709 end;} 1710 {!!!: vaSet: 1711 Writer.WriteSet(ReadSet);} 1712{$ifndef FPUNONE} 1713 vaSingle: 1714 Writer.WriteSingle(ReadSingle); 1715{$endif} 1716 {!!!: vaCurrency: 1717 Writer.WriteCurrency(ReadCurrency);} 1718{$ifndef FPUNONE} 1719 vaDate: 1720 Writer.WriteDate(ReadDate); 1721{$endif} 1722 vaInt64: 1723 Writer.WriteInteger(ReadInt64); 1724 end; 1725end; 1726 1727function TReader.FindComponentClass(const AClassName: String): TComponentClass; 1728 1729var 1730 PersistentClass: TPersistentClass; 1731 ShortClassName: shortstring; 1732 1733 procedure FindInFieldTable(RootComponent: TComponent); 1734 var 1735 FieldTable: PFieldTable; 1736 FieldClassTable: PFieldClassTable; 1737 Entry: TPersistentClass; 1738 i: Integer; 1739 ComponentClassType: TClass; 1740 begin 1741 ComponentClassType := RootComponent.ClassType; 1742 // it is not necessary to look in the FieldTable of TComponent, 1743 // because TComponent doesn't have published properties that are 1744 // descendants of TComponent 1745 while ComponentClassType<>TComponent do 1746 begin 1747 FieldTable:=PVmt(ComponentClassType)^.vFieldTable; 1748 if assigned(FieldTable) then 1749 begin 1750 FieldClassTable := FieldTable^.ClassTable; 1751 for i := 0 to FieldClassTable^.Count -1 do 1752 begin 1753 Entry := FieldClassTable^.Entries[i]{$ifndef VER3_0}^{$endif}; 1754 //writeln(format('Looking for %s in field table of class %s. Found %s', 1755 //[AClassName, ComponentClassType.ClassName, Entry.ClassName])); 1756 if Entry.ClassNameIs(ShortClassName) and 1757 (Entry.InheritsFrom(TComponent)) then 1758 begin 1759 Result := TComponentClass(Entry); 1760 Exit; 1761 end; 1762 end; 1763 end; 1764 // look in parent class 1765 ComponentClassType := ComponentClassType.ClassParent; 1766 end; 1767 end; 1768 1769begin 1770 Result := nil; 1771 ShortClassName:=AClassName; 1772 FindInFieldTable(Root); 1773 1774 if (Result=nil) and assigned(LookupRoot) and (LookupRoot<>Root) then 1775 FindInFieldTable(LookupRoot); 1776 1777 if (Result=nil) then begin 1778 PersistentClass := GetClass(AClassName); 1779 if PersistentClass.InheritsFrom(TComponent) then 1780 Result := TComponentClass(PersistentClass); 1781 end; 1782 1783 if (Result=nil) and assigned(OnFindComponentClass) then 1784 OnFindComponentClass(Self, AClassName, Result); 1785 1786 if (Result=nil) or (not Result.InheritsFrom(TComponent)) then 1787 raise EClassNotFound.CreateFmt(SClassNotFound, [AClassName]); 1788end; 1789 1790 1791{ TAbstractObjectReader } 1792 1793procedure TAbstractObjectReader.FlushBuffer; 1794begin 1795 // Do nothing 1796end; 1797 1798