1{ 2 Author: Mattias Gaertner 3 4 ***************************************************************************** 5 This file is part of the Lazarus Component Library (LCL) 6 7 See the file COPYING.modifiedLGPL.txt, included in this distribution, 8 for details about the license. 9 ***************************************************************************** 10 11 Abstract: 12 This unit maintains and stores all lazarus resources in the global list 13 named LazarusResources and provides methods and types to stream components. 14 15 A lazarus resource is an ansistring, with a name and a valuetype. Both, name 16 and valuetype, are ansistrings as well. 17 Lazarus resources are normally included via an include directive in the 18 initialization part of a unit. To create such include files use the 19 BinaryToLazarusResourceCode procedure. 20 To create a LRS file from an LFM file use the LFMtoLRSfile function which 21 transforms the LFM text to binary format and stores it as Lazarus resource 22 include file. 23} 24unit LResources; 25 26{$mode objfpc}{$H+} 27 28{ $DEFINE WideStringLenDoubled} 29 30interface 31 32uses 33 {$IFDEF Windows} 34 Windows, 35 {$ENDIF} 36 Classes, SysUtils, Types, RtlConsts, TypInfo, variants, 37 // LCL 38 LCLProc, LCLStrConsts, 39 // LazUtils 40 LazConfigStorage, FPCAdds, DynQueue, LazUTF8, LazUTF8Classes, LazLoggerBase; 41 42{$DEFINE UseLRS} 43{$DEFINE UseRES} 44 45const 46 LRSComment = // do not translate this! 47 'This is an automatically generated lazarus resource file'; 48type 49 TFilerSignature = array[1..4] of Char; 50 51 52 { TLResourceList } 53 54 TLResource = class 55 public 56 Name: AnsiString; 57 ValueType: AnsiString; 58 Value: AnsiString; 59 end; 60 61 TLResourceList = class(TObject) 62 private 63 FList: TList; // main list with all resource pointers 64 FMergeList: TList; // list needed for mergesort 65 FSortedCount: integer; // 0 .. FSortedCount-1 resources are sorted 66 function FindPosition(const Name: AnsiString):integer; 67 function GetItems(Index: integer): TLResource; 68 procedure Sort; 69 procedure MergeSort(List, MergeList: TList; Pos1, Pos2: integer); 70 procedure Merge(List, MergeList: TList; Pos1, Pos2, Pos3: integer); 71 public 72 constructor Create; 73 destructor Destroy; override; 74 procedure Add(const Name, ValueType, Value: AnsiString); 75 procedure Add(const Name, ValueType: AnsiString; const Values: array of string); 76 function Find(const Name: AnsiString): TLResource; overload; 77 function Find(const Name, ValueType: AnsiString): TLResource; overload; 78 function Count: integer; 79 property Items[Index: integer]: TLResource read GetItems; 80 end; 81 82 { TLazarusResourceStream } 83 84 TLazarusResourceStream = class(TCustomMemoryStream) 85 private 86 FLRes: TLResource; 87 {$ifdef UseRES} 88 FPRes: TFPResourceHGLOBAL; 89 {$endif} 90 procedure Initialize(Name, ResType: PChar); 91 public 92 constructor Create(const ResName: string; ResType: PChar); 93 constructor CreateFromID(ResID: Integer; ResType: PChar); 94 constructor CreateFromHandle(AHandle: TLResource); overload; 95 {$ifdef UseRES} 96 // here from FP resource handle 97 constructor CreateFromHandle(Instance: TFPResourceHMODULE; AHandle: TFPResourceHandle); overload; 98 {$endif} 99 destructor Destroy; override; 100 function Write(const Buffer; Count: Longint): Longint; override; 101 property Res: TLResource read FLRes; 102 end; 103 104 { TAbstractTranslator} 105 TAbstractTranslator = class(TObject)//Should it be somewhat more than TObject? 106 public 107 procedure TranslateStringProperty(Sender:TObject; const Instance: TPersistent; PropInfo: PPropInfo; var Content:string);virtual;abstract; 108 //seems like we need nothing more here 109 end; 110 111 112var LRSTranslator: TAbstractTranslator; 113 114type 115 TLRSItemType = ( 116 lrsitCollection, 117 lrsitComponent, 118 lrsitList, 119 lrsitProperty 120 ); 121 122 TLRSORStackItem = record 123 Name: string; 124 ItemType: TLRSItemType; 125 Root: TComponent; 126 PushCount: integer; // waiting for this number of Pop 127 ItemNr: integer; // nr in a collection or list 128 end; 129 PLRSORStackItem = ^TLRSORStackItem; 130 131 { TLRSObjectReader } 132 133 TLRSObjectReader = class(TAbstractObjectReader) 134 private 135 FStream: TStream; 136 FBuffer: Pointer; 137 FBufSize: Integer; 138 FBufPos: Integer; 139 FBufEnd: Integer; 140 FStack: PLRSORStackItem; 141 FStackPointer: integer; 142 FStackCapacity: integer; 143 FReader: TReader; 144 procedure SkipProperty; 145 procedure SkipSetBody; 146 procedure Push(ItemType: TLRSItemType; const AName: string = ''; 147 Root: TComponent = nil; PushCount: integer = 1); 148 procedure Pop; 149 procedure ClearStack; 150 function InternalReadValue: TValueType; 151 procedure EndPropertyIfOpen; 152 protected 153 function ReadIntegerContent: integer; 154 public 155 constructor Create(AStream: TStream; BufSize: Integer); virtual; 156 destructor Destroy; override; 157 158 function NextValue: TValueType; override; 159 function ReadValue: TValueType; override; 160 procedure BeginRootComponent; override; 161 procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer; 162 var CompClassName, CompName: String); override; 163 function BeginProperty: String; override; 164 function GetStackPath: string; 165 166 procedure Read(var Buf; Count: LongInt); override; 167 procedure ReadBinary(const DestData: TMemoryStream); override; 168 function ReadFloat: Extended; override; 169 function ReadSingle: Single; override; 170 function ReadCurrency: Currency; override; 171 function ReadDate: TDateTime; override; 172 function ReadIdent(ValueType: TValueType): String; override; 173 function ReadInt8: ShortInt; override; 174 function ReadInt16: SmallInt; override; 175 function ReadInt32: LongInt; override; 176 function ReadInt64: Int64; override; 177 function ReadSet(EnumType: Pointer): Integer; override; 178 {$IF FPC_FULLVERSION >= 30000} 179 procedure ReadSignature; override; 180 {$ENDIF} 181 function ReadStr: String; override; 182 function ReadString(StringType: TValueType): String; override; 183 function ReadWideString: WideString; override; 184 function ReadUnicodeString: UnicodeString; override; 185 procedure SkipComponent(SkipComponentInfos: Boolean); override; 186 procedure SkipValue; override; 187 public 188 property Stream: TStream read FStream; 189 property Reader: TReader read FReader write FReader; 190 end; 191 TLRSObjectReaderClass = class of TLRSObjectReader; 192 193 { TLRSOWStackItem 194 The TLRSObjectWriter can find empty entries and omit writing them to stream. 195 For example: 196 inline ConditionalOptionsFrame: TCompOptsConditionalsFrame 197 inherited COCTreeView: TTreeView 198 end 199 inherited COCPopupMenu: TPopupMenu 200 end 201 end 202 203 The empty inherited child components will not be written if 204 WriteEmptyInheritedChilds = false (default). 205 206 Reason: 207 This allows one to delete/rename controls in ancestors without the need 208 to update all descendants. 209 } 210 211 TLRSOWStackItemState = ( 212 lrsowsisStarted, // now writing header 213 lrsowsisHeaderWritten, // header saved on stack, not yet written to stream, waiting for data 214 lrsowsisDataWritten // header written to stream, data written 215 ); 216 217 TLRSOWStackItem = record 218 Name: string; 219 ItemType: TLRSItemType; 220 Root: TComponent; 221 PushCount: integer; // waiting for this number of Pop 222 ItemNr: integer; // nr in a collection or list 223 SkipIfEmpty: boolean; 224 State: TLRSOWStackItemState; 225 Buffer: Pointer; 226 BufCount: PtrInt; 227 BufCapacity: PtrInt; 228 end; 229 PLRSOWStackItem = ^TLRSOWStackItem; 230 231 { TLRSObjectWriter } 232 233 TLRSObjectWriter = class(TAbstractObjectWriter) 234 private 235 FStream: TStream; 236 FBuffer: Pointer; 237 FBufSize: Integer; 238 FBufPos: Integer; 239 FSignatureWritten: Boolean; 240 FStack: PLRSOWStackItem; 241 FStackPointer: integer; 242 FStackCapacity: integer; 243 FWriteEmptyInheritedChilds: boolean; 244 FWriter: TWriter; 245 procedure Push(ItemType: TLRSItemType; const AName: string = ''; 246 Root: TComponent = nil; PushCount: integer = 1; 247 SkipIfEmpty: boolean = false); 248 procedure EndHeader; 249 procedure Pop(WriteNull: boolean); 250 procedure ClearStack; 251 procedure FlushStackToStream; 252 procedure WriteToStream(const Buffer; Count: Longint); 253 protected 254 procedure FlushBuffer; 255 procedure WriteValue(Value: TValueType); 256 procedure WriteStr(const Value: String); 257 procedure WriteIntegerContent(i: integer); 258 procedure WriteWordContent(w: word); 259 procedure WriteInt64Content(i: int64); 260 procedure WriteSingleContent(s: single); 261 procedure WriteDoubleContent(d: Double); 262 procedure WriteExtendedContent(e: Extended); 263 procedure WriteCurrencyContent(c: Currency); 264 procedure WriteWideStringContent(const ws: WideString); 265 procedure WriteWordsReversed(p: PWord; Count: integer); 266 procedure WriteNulls(Count: integer); 267 public 268 constructor Create(Stream: TStream; BufSize: Integer); virtual; 269 destructor Destroy; override; 270 271 { Begin/End markers. Those ones who don't have an end indicator, use 272 "EndList", after the occurrence named in the comment. Note that this 273 only counts for "EndList" calls on the same level; each BeginXXX call 274 increases the current level. } 275 procedure BeginCollection; override;{ Ends with the next "EndList" } 276 procedure BeginComponent(Component: TComponent; Flags: TFilerFlags; 277 ChildPos: Integer); override; { Ends after the second "EndList" } 278 {$IF FPC_FULLVERSION >= 30000} 279 procedure WriteSignature; override; 280 {$ENDIF} 281 procedure BeginList; override; 282 procedure EndList; override; 283 procedure BeginProperty(const PropName: String); override; 284 procedure EndProperty; override; 285 function GetStackPath: string; 286 287 procedure Write(const Buffer; Count: Longint); override; 288 procedure WriteBinary(const Buffer; Count: LongInt); override; 289 procedure WriteBoolean(Value: Boolean); override; 290 procedure WriteFloat(const Value: Extended); override; 291 procedure WriteSingle(const Value: Single); override; 292 procedure WriteCurrency(const Value: Currency); override; 293 procedure WriteDate(const Value: TDateTime); override; 294 procedure WriteIdent(const Ident: string); override; 295 procedure WriteInteger(Value: Int64); override; 296 procedure WriteMethodName(const Name: String); override; 297 procedure WriteSet(Value: LongInt; SetType: Pointer); override; 298 procedure WriteString(const Value: String); override; 299 procedure WriteWideString(const Value: WideString); override; 300 procedure WriteUnicodeString(const Value: UnicodeString); override; 301 procedure WriteVariant(const Value: Variant); override; 302 303 property WriteEmptyInheritedChilds: boolean read FWriteEmptyInheritedChilds write FWriteEmptyInheritedChilds; 304 property Writer: TWriter read FWriter write FWriter; 305 end; 306 TLRSObjectWriterClass = class of TLRSObjectWriter; 307 308 TLRPositionLink = record 309 LFMPosition: int64; 310 LRSPosition: int64; 311 Data: Pointer; 312 end; 313 PLRPositionLink = ^TLRPositionLink; 314 315 { TLRPositionLinks } 316 317 TLRPositionLinks = class 318 private 319 FItems: TFPList; 320 FCount: integer; 321 function GetData(Index: integer): Pointer; 322 function GetLFM(Index: integer): Int64; 323 function GetLRS(Index: integer): Int64; 324 procedure SetCount(const AValue: integer); 325 procedure SetData(Index: integer; const AValue: Pointer); 326 procedure SetLFM(Index: integer; const AValue: Int64); 327 procedure SetLRS(Index: integer; const AValue: Int64); 328 public 329 constructor Create; 330 destructor Destroy; override; 331 procedure Clear; 332 procedure Sort(LFMPositions: Boolean); 333 function IndexOf(const Position: int64; LFMPositions: Boolean): integer; 334 function IndexOfRange(const FromPos, ToPos: int64; 335 LFMPositions: Boolean): integer; 336 procedure SetPosition(const FromPos, ToPos, MappedPos: int64; 337 LFMtoLRSPositions: Boolean); 338 procedure Add(const LFMPos, LRSPos: Int64; AData: Pointer); 339 public 340 property LFM[Index: integer]: int64 read GetLFM write SetLFM; 341 property LRS[Index: integer]: int64 read GetLRS write SetLRS; 342 property Data[Index: integer]: Pointer read GetData write SetData; 343 property Count: integer read FCount write SetCount; 344 end; 345 346 { TUTF8Parser } 347 348 TUTF8Parser = class(TObject) 349 private 350 fStream : TStream; 351 fBuf : pchar; 352 fBufLen : integer; // read 353 fPos : integer; 354 fLineStart : integer; // column = fPos - fLineStart + 1 355 fFloatType : char; 356 fSourceLine : integer; 357 fToken : char; 358 fEofReached : boolean; 359 fLastTokenStr : string; 360 function GetTokenName(aTok : char) : string; 361 procedure LoadBuffer; 362 procedure CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 363 procedure ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 364 function IsNumber : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 365 function IsHexNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 366 function IsAlpha : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 367 function IsAlphaNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 368 function GetHexValue(c : char) : byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 369 function GetAlphaNum : string; 370 procedure HandleNewLine; 371 procedure SkipSpaces; 372 procedure SkipWhitespace; 373 procedure HandleEof; 374 procedure HandleAlphaNum; 375 procedure HandleNumber; 376 procedure HandleHexNumber; 377 function HandleQuotedString: string; 378 function HandleDecimalString: string; 379 procedure HandleString; 380 procedure HandleMinus; 381 procedure HandleUnknown; 382 public 383 constructor Create(Stream: TStream); 384 destructor Destroy; override; 385 procedure CheckToken(T: Char); 386 procedure CheckTokenSymbol(const S: string); 387 procedure Error(const Ident: string); 388 procedure ErrorFmt(const Ident: string; const Args: array of const); 389 procedure ErrorStr(const Message: string); 390 procedure HexToBinary(Stream: TStream); 391 function NextToken: Char; 392 function SourcePos: Longint; 393 function TokenComponentIdent: string; 394 function TokenFloat: Extended; 395 function TokenInt: Int64; 396 function TokenString: string; 397 function TokenSymbolIs(const S: string): Boolean; 398 property FloatType: Char read fFloatType; 399 property SourceLine: Integer read fSourceLine; 400 function SourceColumn: integer; 401 property Token: Char read fToken; 402 end; 403 404 { TCustomLazComponentQueue 405 A queue to stream components, used for multithreading or network. 406 The function ConvertComponentAsString converts a component to binary format 407 with a leading size information (using WriteLRSInt64MB). 408 When streaming components over network, they will arrive in chunks. 409 TCustomLazComponentQueue tells you, if a whole component has arrived and if 410 it has completely arrived. } 411 TCustomLazComponentQueue = class(TComponent) 412 private 413 FOnFindComponentClass: TFindComponentClassEvent; 414 protected 415 FQueue: TDynamicDataQueue; 416 function ReadComponentSize(out ComponentSize, SizeLength: int64): Boolean; virtual; 417 public 418 constructor Create(TheOwner: TComponent); override; 419 destructor Destroy; override; 420 procedure Clear; 421 function Write(const Buffer; Count: Longint): Longint; 422 function CopyFrom(AStream: TStream; Count: Longint): Longint; 423 function HasComponent: Boolean; virtual; 424 function ReadComponent(var AComponent: TComponent; 425 NewOwner: TComponent = nil): Boolean; virtual; 426 function ConvertComponentAsString(AComponent: TComponent): string; 427 property OnFindComponentClass: TFindComponentClassEvent 428 read FOnFindComponentClass write FOnFindComponentClass; 429 end; 430 431 { TLazComponentQueue } 432 433 TLazComponentQueue = class(TCustomLazComponentQueue) 434 published 435 property Name; 436 property OnFindComponentClass; 437 end; 438 439 TPropertyToSkip = record 440 PersistentClass: TPersistentClass; 441 PropertyName: String; 442 Note: String; 443 HelpKeyword: String; 444 end; 445 PRemovedProperty = ^TPropertyToSkip; 446 447 { TPropertyToSkipList } 448 449 TPropertiesToSkip = class(TList) 450 private 451 function GetItem(AIndex: Integer): PRemovedProperty; 452 procedure SetItem(AIndex: Integer; const AValue: PRemovedProperty); 453 protected 454 procedure Notify(Ptr: Pointer; Action: TListNotification); override; 455 procedure DoPropertyNotFound(Reader: TReader; Instance: TPersistent; 456 var PropName: string; IsPath: boolean; var Handled, Skip: Boolean); 457 public 458 function IndexOf(AInstance: TPersistent; const APropertyName: String): Integer; overload; 459 function IndexOf(AClass: TPersistentClass; APropertyName: String): Integer; overload; 460 function Add(APersistentClass: TPersistentClass; const APropertyName, ANote, 461 AHelpKeyWord: string): Integer; reintroduce; 462 property Items[AIndex: Integer]: PRemovedProperty read GetItem write SetItem; 463 end; 464 465const 466 ObjStreamMaskInherited = 1; 467 ObjStreamMaskChildPos = 2; 468 ObjStreamMaskInline = 4; 469 470var 471 LazarusResources: TLResourceList; 472 PropertiesToSkip: TPropertiesToSkip = nil; 473 474 LRSObjectReaderClass: TLRSObjectReaderClass=TLRSObjectReader; 475 LRSObjectWriterClass: TLRSObjectWriterClass=TLRSObjectWriter; 476 477function InitResourceComponent(Instance: TComponent; 478 RootAncestor: TClass):Boolean; 479function InitLazResourceComponent(Instance: TComponent; 480 RootAncestor: TClass): Boolean; 481function CreateLRSReader(s: TStream; var DestroyDriver: boolean): TReader; 482function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter; 483 484function GetClassNameFromLRSStream(s: TStream; out IsInherited: Boolean): shortstring; 485procedure GetComponentInfoFromLRSStream(s: TStream; 486 out ComponentName, ComponentClassName: string; 487 out IsInherited: Boolean); 488procedure WriteComponentAsBinaryToStream(AStream: TStream; 489 AComponent: TComponent); 490procedure ReadComponentFromBinaryStream(AStream: TStream; 491 var RootComponent: TComponent; 492 OnFindComponentClass: TFindComponentClassEvent; 493 TheOwner: TComponent = nil; 494 Parent: TComponent = nil; 495 ReaderRoot: TComponent = nil); 496procedure WriteComponentAsTextToStream(AStream: TStream; 497 AComponent: TComponent); 498procedure ReadComponentFromTextStream(AStream: TStream; 499 var RootComponent: TComponent; 500 OnFindComponentClass: TFindComponentClassEvent; 501 TheOwner: TComponent = nil; 502 Parent: TComponent = nil); 503procedure SaveComponentToConfig(Config: TConfigStorage; const Path: string; 504 AComponent: TComponent); 505procedure LoadComponentFromConfig(Config: TConfigStorage; const Path: string; 506 var RootComponent: TComponent; 507 OnFindComponentClass: TFindComponentClassEvent; 508 TheOwner: TComponent = nil; 509 Parent: TComponent = nil); 510 511 512function CompareComponents(Component1, Component2: TComponent): boolean; 513function CompareMemStreams(Stream1, Stream2: TCustomMemoryStream): boolean; 514 515procedure BinaryToLazarusResourceCode(BinStream, ResStream: TStream; 516 const ResourceName, ResourceType: String); 517function LFMtoLRSfile(const LFMfilename: string): boolean;// true on success 518function LFMtoLRSstream(LFMStream, LRSStream: TStream): boolean;// true on success 519function FindLFMClassName(LFMStream: TStream):AnsiString; 520procedure ReadLFMHeader(LFMStream: TStream; 521 out LFMType, LFMComponentName, LFMClassName: String); 522procedure ReadLFMHeader(const LFMSource: string; 523 out LFMClassName: String; out LFMType: String); 524procedure ReadLFMHeader(const LFMSource: string; 525 out LFMType, LFMComponentName, LFMClassName: String); 526function ReadLFMHeaderFromFile(const Filename: string; 527 out LFMType, LFMComponentName, LFMClassName: String): boolean; 528function CreateLFMFile(AComponent: TComponent; LFMStream: TStream): integer; 529 530type 531 TLRSStreamOriginalFormat = (sofUnknown, sofBinary, sofText); 532 533procedure LRSObjectBinaryToText(Input, Output: TStream); // binary to lfm 534procedure LRSObjectTextToBinary(Input, Output: TStream; // lfm to binary 535 Links: TLRPositionLinks = nil); 536procedure LRSObjectToText(Input, Output: TStream; 537 var OriginalFormat: TLRSStreamOriginalFormat); 538 539procedure LRSObjectResourceToText(Input, Output: TStream); // lrs to lfm 540procedure LRSObjectResToText(Input, Output: TStream; 541 var OriginalFormat: TLRSStreamOriginalFormat); 542 543function TestFormStreamFormat(Stream: TStream): TLRSStreamOriginalFormat; 544procedure FormDataToText(FormStream, TextStream: TStream; 545 aFormat: TLRSStreamOriginalFormat = sofUnknown); 546 547function FindResourceLFM(ResName: string): HRSRC; 548 549procedure DefineRectProperty(Filer: TFiler; const Name: string; 550 ARect, DefaultRect: PRect); 551 552procedure ReverseBytes(p: Pointer; Count: integer); 553procedure ReverseByteOrderInWords(p: PWord; Count: integer); 554function ConvertLRSExtendedToDouble(p: Pointer): Double; 555procedure ConvertEndianBigDoubleToLRSExtended(BigEndianDouble, 556 LRSExtended: Pointer); 557 558procedure ConvertLEDoubleToLRSExtended(LEDouble, LRSExtended: Pointer); 559 560 561function ReadLRSShortInt(s: TStream): shortint; 562function ReadLRSByte(s: TStream): byte; 563function ReadLRSSmallInt(s: TStream): smallint; 564function ReadLRSWord(s: TStream): word; 565function ReadLRSInteger(s: TStream): integer; 566function ReadLRSCardinal(s: TStream): cardinal; 567function ReadLRSInt64(s: TStream): int64; 568function ReadLRSSingle(s: TStream): Single; 569function ReadLRSDouble(s: TStream): Double; 570function ReadLRSExtended(s: TStream): Extended; 571function ReadLRSCurrency(s: TStream): Currency; 572function ReadLRSWideString(s: TStream): WideString; 573function ReadLRSEndianLittleExtendedAsDouble(s: TStream): Double; 574function ReadLRSValueType(s: TStream): TValueType; 575function ReadLRSInt64MB(s: TStream): int64;// multibyte 576 577procedure WriteLRSSmallInt(s: TStream; const i: smallint); 578procedure WriteLRSWord(s: TStream; const w: word); 579procedure WriteLRSInteger(s: TStream; const i: integer); 580procedure WriteLRSCardinal(s: TStream; const c: cardinal); 581procedure WriteLRSSingle(s: TStream; const si: Single); 582procedure WriteLRSDouble(s: TStream; const d: Double); 583procedure WriteLRSExtended(s: TStream; const e: extended); 584procedure WriteLRSInt64(s: TStream; const i: int64); 585procedure WriteLRSCurrency(s: TStream; const c: Currency); 586procedure WriteLRSWideStringContent(s: TStream; const w: WideString); 587procedure WriteLRSInt64MB(s: TStream; const Value: int64);// multibyte 588 589procedure WriteLRSReversedWord(s: TStream; w: word); 590procedure WriteLRS4BytesReversed(s: TStream; p: Pointer); 591procedure WriteLRS8BytesReversed(s: TStream; p: Pointer); 592procedure WriteLRS10BytesReversed(s: TStream; p: Pointer); 593procedure WriteLRSNull(s: TStream; Count: integer); 594procedure WriteLRSEndianBigDoubleAsEndianLittleExtended(s: TStream; 595 EndBigDouble: PByte); 596procedure WriteLRSDoubleAsExtended(s: TStream; ADouble: PByte); 597procedure WriteLRSReversedWords(s: TStream; p: Pointer; Count: integer); 598 599function FloatToLFMStr(const Value: extended; Precision, Digits: Integer 600 ): string; 601 602function CompareLRPositionLinkWithLFMPosition(Item1, Item2: Pointer): integer; 603function CompareLRPositionLinkWithLRSPosition(Item1, Item2: Pointer): integer; 604 605procedure RegisterPropertyToSkip(PersistentClass: TPersistentClass; 606 const PropertyName, Note, HelpKeyWord: string); 607 608procedure Register; 609 610implementation 611 612const 613 LineEnd: ShortString = LineEnding; 614 615var 616 ByteToStr: array[char] of shortstring; 617 ByteToStrValid: boolean=false; 618 619type 620 621 { TDefineRectPropertyClass } 622 623 TDefineRectPropertyClass = class 624 public 625 Value: PRect; 626 DefaultValue: PRect; 627 constructor Create(AValue, ADefaultRect: PRect); 628 procedure ReadData(Reader: TReader); 629 procedure WriteData(Writer: TWriter); 630 function HasData: Boolean; 631 end; 632 633 { TReaderUniqueNamer - dummy class, used by the reader functions to rename 634 components, that are read from a stream, on the fly. } 635 636 TReaderUniqueNamer = class 637 procedure OnSetName(Reader: TReader; Component: TComponent; 638 var Name: string); 639 end; 640 641{ TPropertiesToSkip } 642 643function TPropertiesToSkip.GetItem(AIndex: Integer): PRemovedProperty; 644begin 645 Result := inherited Get(AIndex); 646end; 647 648procedure TPropertiesToSkip.SetItem(AIndex: Integer; 649 const AValue: PRemovedProperty); 650begin 651 inherited Put(AIndex, AValue); 652end; 653 654procedure TPropertiesToSkip.Notify(Ptr: Pointer; Action: TListNotification); 655begin 656 if Action = lnDeleted then 657 Dispose(PRemovedProperty(Ptr)) 658 else 659 inherited Notify(Ptr, Action); 660end; 661 662procedure TPropertiesToSkip.DoPropertyNotFound(Reader: TReader; Instance: TPersistent; 663 var PropName: string; IsPath: boolean; var Handled, Skip: Boolean); 664begin 665 Skip := IndexOf(Instance, PropName) >= 0; 666 Handled := Skip; 667end; 668 669function TPropertiesToSkip.IndexOf(AInstance: TPersistent; 670 const APropertyName: String): Integer; 671begin 672 if AInstance <> nil then 673 Result := IndexOf(TPersistentClass(AInstance.ClassType), APropertyName) 674 else 675 Result := -1; 676end; 677 678function TPropertiesToSkip.IndexOf(AClass: TPersistentClass; 679 APropertyName: String): Integer; 680var 681 PropertyInfo: PRemovedProperty; 682begin 683 APropertyName := LowerCase(APropertyName); 684 Result := Count - 1; 685 while Result >= 0 do 686 begin 687 PropertyInfo := Items[Result]; 688 if AClass.InheritsFrom(PropertyInfo^.PersistentClass) and 689 (APropertyName = PropertyInfo^.PropertyName) then 690 begin 691 Exit; 692 end; 693 Dec(Result); 694 end; 695 Result := -1; 696end; 697 698function TPropertiesToSkip.Add(APersistentClass: TPersistentClass; 699 const APropertyName, ANote, AHelpKeyWord: string): Integer; 700var 701 Item: PRemovedProperty; 702begin 703 Result := IndexOf(APersistentClass, APropertyName); 704 if Result = -1 then 705 begin 706 New(Item); 707 Item^.PersistentClass := APersistentClass; 708 Item^.PropertyName := LowerCase(APropertyName); 709 Item^.Note := ANote; 710 Item^.HelpKeyword := AHelpKeyWord; 711 Result := inherited Add(Item); 712 end; 713end; 714 715{ TReaderUniqueNamer } 716 717procedure TReaderUniqueNamer.OnSetName(Reader: TReader; Component: TComponent; 718 var Name: string); 719 720 procedure MakeValidIdentifier; 721 var 722 i: Integer; 723 begin 724 for i:=length(Name) downto 1 do 725 if not (Name[i] in ['0'..'9','_','a'..'z','A'..'Z']) then 726 System.Delete(Name,i,1); 727 if (Name<>'') and (Name[1] in ['0'..'9']) then 728 Name:='_'+Name; 729 end; 730 731 function NameIsUnique: Boolean; 732 var 733 Owner: TComponent; 734 i: Integer; 735 CurComponent: TComponent; 736 begin 737 Result:=true; 738 if Name='' then exit; 739 Owner:=Component.Owner; 740 if Owner=nil then exit; 741 for i:=0 to Owner.ComponentCount-1 do begin 742 CurComponent:=Owner.Components[i]; 743 if CurComponent=Component then continue; 744 if CompareText(CurComponent.Name,Name)=0 then exit(false); 745 end; 746 end; 747 748begin 749 MakeValidIdentifier; 750 while not NameIsUnique do 751 Name:=CreateNextIdentifier(Name); 752end; 753 754{ TDefineRectPropertyClass } 755 756constructor TDefineRectPropertyClass.Create(AValue, ADefaultRect: PRect); 757begin 758 Value:=AValue; 759 DefaultValue:=ADefaultRect; 760end; 761 762procedure TDefineRectPropertyClass.ReadData(Reader: TReader); 763begin 764 with Reader do begin 765 ReadListBegin; 766 Value^.Left:=ReadInteger; 767 Value^.Top:=ReadInteger; 768 Value^.Right:=ReadInteger; 769 Value^.Bottom:=ReadInteger; 770 ReadListEnd; 771 end; 772end; 773 774procedure TDefineRectPropertyClass.WriteData(Writer: TWriter); 775begin 776 with Writer do begin 777 WriteListBegin; 778 WriteInteger(Value^.Left); 779 WriteInteger(Value^.Top); 780 WriteInteger(Value^.Right); 781 WriteInteger(Value^.Bottom); 782 WriteListEnd; 783 end; 784end; 785 786function TDefineRectPropertyClass.HasData: Boolean; 787begin 788 if DefaultValue<>nil then begin 789 Result:=(DefaultValue^.Left<>Value^.Left) 790 or (DefaultValue^.Top<>Value^.Top) 791 or (DefaultValue^.Right<>Value^.Right) 792 or (DefaultValue^.Bottom<>Value^.Bottom); 793 end else begin 794 Result:=(Value^.Left<>0) 795 or (Value^.Top<>0) 796 or (Value^.Right<>0) 797 or (Value^.Bottom<>0); 798 end; 799end; 800 801function InitResourceComponent(Instance: TComponent; 802 RootAncestor: TClass):Boolean; 803begin 804 Result := InitLazResourceComponent(Instance, RootAncestor); 805end; 806 807function FindResourceLFM(ResName: string): HRSRC; 808{$if defined(WinCE)} 809//function FindResourceLFM(ResName: string): HRSRC; 810//{$if (FPC_FULLVERSION>=20605) and defined(WinCE)} 811var 812 u: UnicodeString; 813begin 814 u:=ResName; 815 Result := FindResource(HInstance,PWideChar(u),Windows.RT_RCDATA); 816end; 817{$else} 818begin 819 Result := FindResource(HInstance,PChar(ResName), 820 {$if (FPC_FULLVERSION>=20701) and defined(Windows)}Windows.{$endif}RT_RCDATA); 821end; 822{$endif} 823 824procedure DefineRectProperty(Filer: TFiler; const Name: string; ARect, 825 DefaultRect: PRect); 826var 827 PropDef: TDefineRectPropertyClass; 828begin 829 PropDef := TDefineRectPropertyClass.Create(ARect, DefaultRect); 830 try 831 Filer.DefineProperty(Name,@PropDef.ReadData,@PropDef.WriteData,PropDef.HasData); 832 finally 833 PropDef.Free; 834 end; 835end; 836 837procedure InitByteToStr; 838var 839 c: Char; 840begin 841 if ByteToStrValid then exit; 842 for c:=Low(char) to High(char) do 843 ByteToStr[c]:=IntToStr(ord(c)); 844 ByteToStrValid:=true; 845end; 846 847function GetClassNameFromLRSStream(s: TStream; out IsInherited: Boolean 848 ): shortstring; 849var 850 Signature: TFilerSignature; 851 NameLen: byte; 852 OldPosition: Int64; 853begin 854 Result:=''; 855 OldPosition:=s.Position; 856 // read signature 857 Signature:='1234'; 858 s.Read(Signature[1],length(Signature)); 859 if Signature<>FilerSignature then exit; 860 // read classname length 861 NameLen:=0; 862 s.Read(NameLen,1); 863 if (NameLen and $f0) = $f0 then begin 864 // this was the Flag Byte 865 IsInherited := (NameLen and ObjStreamMaskInherited) <> 0; 866 // read namelen 867 s.Read(NameLen,1); 868 end else 869 IsInherited := False; 870 // read classname 871 if NameLen>0 then begin 872 SetLength(Result,NameLen); 873 s.Read(Result[1],NameLen); 874 end; 875 s.Position:=OldPosition; 876end; 877 878procedure GetComponentInfoFromLRSStream(s: TStream; out ComponentName, 879 ComponentClassName: string; out IsInherited: Boolean); 880var 881 Signature: TFilerSignature; 882 NameLen: byte; 883 OldPosition: Int64; 884 Flag: Byte; 885begin 886 ComponentName:=''; 887 ComponentClassName:=''; 888 OldPosition:=s.Position; 889 // read signature 890 Signature:='1234'; 891 s.Read(Signature[1],length(Signature)); 892 if Signature<>FilerSignature then exit; 893 // read classname length 894 NameLen:=0; 895 s.Read(NameLen,1); 896 if (NameLen and $f0) = $f0 then begin 897 // Read Flag Byte 898 Flag:=NameLen; 899 IsInherited := (Flag and ObjStreamMaskInherited) <> 0; 900 s.Read(NameLen,1); 901 end else 902 IsInherited := False; 903 // read classname 904 if NameLen>0 then begin 905 SetLength(ComponentClassName,NameLen); 906 s.Read(ComponentClassName[1],NameLen); 907 end; 908 // read component name length 909 NameLen:=0; 910 s.Read(NameLen,1); 911 // read componentname 912 if NameLen>0 then begin 913 SetLength(ComponentName,NameLen); 914 s.Read(ComponentName[1],NameLen); 915 end; 916 s.Position:=OldPosition; 917end; 918 919procedure WriteComponentAsBinaryToStream(AStream: TStream; 920 AComponent: TComponent); 921var 922 Writer: TWriter; 923 DestroyDriver: Boolean; 924begin 925 DestroyDriver:=false; 926 Writer:=nil; 927 try 928 Writer:=CreateLRSWriter(AStream,DestroyDriver); 929 Writer.WriteDescendent(AComponent,nil); 930 finally 931 if DestroyDriver then 932 Writer.Driver.Free; 933 Writer.Free; 934 end; 935end; 936 937procedure ReadComponentFromBinaryStream(AStream: TStream; 938 var RootComponent: TComponent; 939 OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent; 940 Parent: TComponent; ReaderRoot: TComponent); 941var 942 DestroyDriver: Boolean; 943 Reader: TReader; 944 IsInherited: Boolean; 945 AClassName: String; 946 AClass: TComponentClass; 947 UniqueNamer: TReaderUniqueNamer; 948begin 949 // get root class 950 AClassName:=GetClassNameFromLRSStream(AStream,IsInherited); 951 if IsInherited then begin 952 // inherited is not supported by this simple function 953 {$IFNDEF DisableChecks} 954 DebugLn('ReadComponentFromBinaryStream WARNING: "inherited" is not supported by this simple function'); 955 {$ENDIF} 956 end; 957 AClass:=nil; 958 OnFindComponentClass(nil,AClassName,AClass); 959 if AClass=nil then 960 raise EClassNotFound.CreateFmt('Class "%s" not found', [AClassName]); 961 962 if RootComponent=nil then begin 963 // create root component 964 // first create the new instance and set the variable ... 965 RootComponent:=AClass.NewInstance as TComponent; 966 // then call the constructor 967 RootComponent.Create(TheOwner); 968 end else begin 969 // there is a root component, check if class is compatible 970 if not RootComponent.InheritsFrom(AClass) then begin 971 raise EComponentError.CreateFmt('Cannot assign a %s to a %s.', 972 [AClassName,RootComponent.ClassName]); 973 end; 974 end; 975 976 // read the root component 977 DestroyDriver:=false; 978 Reader:=nil; 979 UniqueNamer:=nil; 980 try 981 UniqueNamer:=TReaderUniqueNamer.Create; 982 Reader:=CreateLRSReader(AStream,DestroyDriver); 983 if ReaderRoot = nil then 984 Reader.Root:=RootComponent 985 else 986 Reader.Root:=ReaderRoot; 987 Reader.Owner:=TheOwner; 988 Reader.Parent:=Parent; 989 Reader.OnFindComponentClass:=OnFindComponentClass; 990 Reader.OnSetName:=@UniqueNamer.OnSetName; 991 Reader.BeginReferences; 992 try 993 Reader.Driver.BeginRootComponent; 994 RootComponent:=Reader.ReadComponent(RootComponent); 995 Reader.FixupReferences; 996 finally 997 Reader.EndReferences; 998 end; 999 finally 1000 if DestroyDriver then 1001 Reader.Driver.Free; 1002 UniqueNamer.Free; 1003 Reader.Free; 1004 end; 1005end; 1006 1007procedure WriteComponentAsTextToStream(AStream: TStream; AComponent: TComponent); 1008var 1009 BinStream: TMemoryStream; 1010begin 1011 BinStream:=nil; 1012 try 1013 BinStream:=TMemoryStream.Create; 1014 WriteComponentAsBinaryToStream(BinStream,AComponent); 1015 BinStream.Position:=0; 1016 LRSObjectBinaryToText(BinStream,AStream); 1017 finally 1018 BinStream.Free; 1019 end; 1020end; 1021 1022procedure ReadComponentFromTextStream(AStream: TStream; 1023 var RootComponent: TComponent; 1024 OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent; 1025 Parent: TComponent); 1026var 1027 BinStream: TMemoryStream; 1028begin 1029 BinStream:=nil; 1030 try 1031 BinStream:=TMemoryStream.Create; 1032 LRSObjectTextToBinary(AStream,BinStream); 1033 BinStream.Position:=0; 1034 ReadComponentFromBinaryStream(BinStream,RootComponent,OnFindComponentClass, 1035 TheOwner,Parent); 1036 finally 1037 BinStream.Free; 1038 end; 1039end; 1040 1041procedure SaveComponentToConfig(Config: TConfigStorage; const Path: string; 1042 AComponent: TComponent); 1043var 1044 BinStream: TMemoryStream; 1045 TxtStream: TMemoryStream; 1046 s: string; 1047begin 1048 BinStream:=nil; 1049 TxtStream:=nil; 1050 try 1051 // write component to stream 1052 BinStream:=TMemoryStream.Create; 1053 WriteComponentAsBinaryToStream(BinStream,AComponent); 1054 // convert it to human readable text format 1055 BinStream.Position:=0; 1056 TxtStream:=TMemoryStream.Create; 1057 LRSObjectBinaryToText(BinStream,TxtStream); 1058 // convert stream to string 1059 SetLength(s,TxtStream.Size); 1060 TxtStream.Position:=0; 1061 if s<>'' then 1062 TxtStream.Read(s[1],length(s)); 1063 // write to config 1064 Config.SetDeleteValue(Path,s,''); 1065 finally 1066 BinStream.Free; 1067 TxtStream.Free; 1068 end; 1069end; 1070 1071procedure LoadComponentFromConfig(Config: TConfigStorage; const Path: string; 1072 var RootComponent: TComponent; 1073 OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent; 1074 Parent: TComponent); 1075var 1076 s: String; 1077 TxtStream: TMemoryStream; 1078begin 1079 // read from config 1080 s:=Config.GetValue(Path,''); 1081 TxtStream:=nil; 1082 try 1083 TxtStream:=TMemoryStream.Create; 1084 if s<>'' then 1085 TxtStream.Write(s[1],length(s)); 1086 TxtStream.Position:=0; 1087 // create component from stream 1088 ReadComponentFromTextStream(TxtStream,RootComponent,OnFindComponentClass, 1089 TheOwner,Parent); 1090 finally 1091 TxtStream.Free; 1092 end; 1093end; 1094 1095function CompareComponents(Component1, Component2: TComponent): boolean; 1096var 1097 Stream1: TMemoryStream; 1098 Stream2: TMemoryStream; 1099 i: Integer; 1100begin 1101 if Component1=Component2 then exit(true); 1102 Result:=false; 1103 // quick checks 1104 if (Component1=nil) or (Component2=nil) then exit; 1105 if (Component1.ClassType<>Component2.ClassType) then exit; 1106 if Component1.ComponentCount<>Component2.ComponentCount then exit; 1107 for i:=0 to Component1.ComponentCount-1 do begin 1108 if Component1.Components[i].ClassType<>Component2.Components[i].ClassType 1109 then exit; 1110 end; 1111 // expensive streaming test 1112 try 1113 Stream1:=nil; 1114 Stream2:=nil; 1115 try 1116 Stream1:=TMemoryStream.Create; 1117 WriteComponentAsBinaryToStream(Stream1,Component1); 1118 Stream2:=TMemoryStream.Create; 1119 WriteComponentAsBinaryToStream(Stream2,Component2); 1120 Result:=CompareMemStreams(Stream1,Stream2); 1121 finally 1122 Stream1.Free; 1123 Stream2.Free; 1124 end; 1125 except 1126 end; 1127end; 1128 1129function CompareMemStreams(Stream1, Stream2: TCustomMemoryStream 1130 ): boolean; 1131var 1132 p1: Pointer; 1133 p2: Pointer; 1134 Cnt: Int64; 1135 CurCnt: cardinal; 1136begin 1137 if Stream1=Stream2 then exit(true); 1138 Result:=false; 1139 if (Stream1=nil) or (Stream2=nil) then exit; 1140 if Stream1.Size<>Stream2.Size then exit; 1141 Cnt:=Stream1.Size; 1142 p1:=Stream1.Memory; 1143 p2:=Stream2.Memory; 1144 while Cnt>0 do begin 1145 CurCnt:=Cnt; 1146 if CurCnt>=High(Cardinal) then CurCnt:=High(Cardinal); 1147 if not CompareMem(p1,p2,CurCnt) then exit; 1148 inc(p1,CurCnt); 1149 inc(p2,CurCnt); 1150 dec(Cnt,CurCnt); 1151 end; 1152 Result:=true; 1153end; 1154 1155procedure BinaryToLazarusResourceCode(BinStream,ResStream:TStream; 1156 const ResourceName, ResourceType: String); 1157{ example ResStream: 1158 LazarusResources.Add('ResourceName','ResourceType', 1159 #123#45#34#78#18#72#45#34#78#18#72#72##45#34#78#45#34#78#184#34#78#145#34#78 1160 +#83#187#6#78#83 1161 ); 1162} 1163const 1164 ReadBufSize = 4096; 1165 WriteBufSize = 4096; 1166var 1167 s, Indent: string; 1168 x: integer; 1169 c: char; 1170 RangeString, NewRangeString: boolean; 1171 RightMargin, CurLine: integer; 1172 WriteBufStart, Writebuf: PChar; 1173 WriteBufPos: Integer; 1174 ReadBufStart, ReadBuf: PChar; 1175 ReadBufPos, ReadBufLen: integer; 1176 MinCharCount: Integer; 1177 1178 procedure FillReadBuf; 1179 begin 1180 ReadBuf:=ReadBufStart; 1181 ReadBufPos:=0; 1182 ReadBufLen:=BinStream.Read(ReadBuf^,ReadBufSize); 1183 end; 1184 1185 procedure InitReadBuf; 1186 begin 1187 GetMem(ReadBufStart,ReadBufSize); 1188 FillReadBuf; 1189 end; 1190 1191 function ReadChar(var c: char): boolean; 1192 begin 1193 if ReadBufPos>=ReadBufLen then begin 1194 FillReadBuf; 1195 if ReadBufLen=0 then begin 1196 Result:=false; 1197 exit; 1198 end; 1199 end; 1200 c:=ReadBuf^; 1201 inc(ReadBuf); 1202 inc(ReadBufPos); 1203 Result:=true; 1204 end; 1205 1206 procedure InitWriteBuf; 1207 begin 1208 GetMem(WriteBufStart,WriteBufSize); 1209 WriteBuf:=WriteBufStart; 1210 WriteBufPos:=0; 1211 end; 1212 1213 procedure FlushWriteBuf; 1214 begin 1215 if WriteBufPos>0 then begin 1216 ResStream.Write(WriteBufStart^,WriteBufPos); 1217 WriteBuf:=WriteBufStart; 1218 WriteBufPos:=0; 1219 end; 1220 end; 1221 1222 procedure WriteChar(c: char); 1223 begin 1224 WriteBuf^:=c; 1225 inc(WriteBufPos); 1226 inc(WriteBuf); 1227 if WriteBufPos>=WriteBufSize then 1228 FlushWriteBuf; 1229 end; 1230 1231 procedure WriteString(const s: string); 1232 var 1233 i: Integer; 1234 begin 1235 for i:=1 to length(s) do WriteChar(s[i]); 1236 end; 1237 1238 procedure WriteShortString(const s: string); 1239 var 1240 i: Integer; 1241 begin 1242 for i:=1 to length(s) do WriteChar(s[i]); 1243 end; 1244 1245begin 1246 // fpc is not optimized for building a constant string out of thousands of 1247 // lines. It needs huge amounts of memory and becomes very slow. Therefore big 1248 // files are split into several strings. 1249 1250 InitReadBuf; 1251 InitWriteBuf; 1252 InitByteToStr; 1253 1254 Indent:=''; 1255 s:=Indent+'LazarusResources.Add('''+ResourceName+''','''+ResourceType+''',['+LineEnd; 1256 WriteString(s); 1257 Indent:=' '+Indent; 1258 WriteString(Indent); 1259 x:=length(Indent); 1260 RangeString:=false; 1261 CurLine:=1; 1262 RightMargin:=80; 1263 if ReadBufLen>0 then begin 1264 while ReadChar(c) do begin 1265 NewRangeString:=(ord(c)>=32) and (ord(c)<127); 1266 // check if new char fits into line or if a new line must be started 1267 if NewRangeString then begin 1268 if RangeString then 1269 MinCharCount:=2 // char plus ' 1270 else 1271 MinCharCount:=3; // ' plus char plus ' 1272 if c='''' then inc(MinCharCount); 1273 end else begin 1274 MinCharCount:=1+length(ByteToStr[c]); // # plus number 1275 if RangeString then 1276 inc(MinCharCount); // plus ' for ending last string constant 1277 end; 1278 if x+MinCharCount>RightMargin then begin 1279 // break line 1280 if RangeString then begin 1281 // end string constant 1282 WriteChar(''''); 1283 end; 1284 // write line ending 1285 WriteShortString(LineEnd); 1286 x:=0; 1287 inc(CurLine); 1288 // write indention 1289 WriteString(Indent); 1290 inc(x,length(Indent)); 1291 // write operator 1292 if (CurLine and 63)<>1 then 1293 WriteChar('+') 1294 else 1295 WriteChar(','); 1296 inc(x); 1297 RangeString:=false; 1298 end; 1299 // write converted byte 1300 if RangeString<>NewRangeString then begin 1301 WriteChar(''''); 1302 inc(x); 1303 end; 1304 if NewRangeString then begin 1305 WriteChar(c); 1306 inc(x); 1307 if c='''' then begin 1308 WriteChar(c); 1309 inc(x); 1310 end; 1311 end else begin 1312 WriteChar('#'); 1313 inc(x); 1314 WriteShortString(ByteToStr[c]); 1315 inc(x,length(ByteToStr[c])); 1316 end; 1317 // next 1318 RangeString:=NewRangeString; 1319 end; 1320 if RangeString then begin 1321 WriteChar(''''); 1322 end; 1323 end else begin 1324 WriteShortString(''''''); 1325 end; 1326 Indent:=copy(Indent,3,length(Indent)-2); 1327 s:=LineEnd+Indent+']);'+LineEnd; 1328 WriteString(s); 1329 FlushWriteBuf; 1330 FreeMem(ReadBufStart); 1331 FreeMem(WriteBufStart); 1332end; 1333 1334function FindLFMClassName(LFMStream:TStream):ansistring; 1335{ examples: 1336 object Form1: TForm1 1337 inherited AboutBox2: TAboutBox2 1338 1339 -> the classname is the last word of the first line 1340} 1341var c:char; 1342 StartPos, EndPos: Int64; 1343begin 1344 Result:=''; 1345 StartPos:=-1; 1346 c:=' '; 1347 // read till end of line 1348 repeat 1349 // remember last non identifier char position 1350 if (not (c in ['a'..'z','A'..'Z','0'..'9','_'])) then 1351 StartPos:=LFMStream.Position; 1352 if LFMStream.Read(c,1)<>1 then exit; 1353 if LFMStream.Position>1000 then exit; 1354 until c in [#10,#13]; 1355 if StartPos<0 then exit; 1356 EndPos:=LFMStream.Position-1; 1357 if EndPos-StartPos>255 then exit; 1358 SetLength(Result,EndPos-StartPos); 1359 LFMStream.Position:=StartPos; 1360 if Length(Result) > 0 then 1361 LFMStream.Read(Result[1],length(Result)); 1362 LFMStream.Position:=0; 1363 if not IsValidIdent(Result) then 1364 Result:=''; 1365end; 1366 1367function LFMtoLRSfile(const LFMfilename: string):boolean; 1368// returns true if successful 1369var 1370 LFMFileStream, LRSFileStream: TFileStreamUTF8; 1371 LFMMemStream, LRSMemStream: TMemoryStream; 1372 LRSfilename, LFMfilenameExt: string; 1373begin 1374 Result:=true; 1375 try 1376 LFMFileStream:=TFileStreamUTF8.Create(LFMfilename,fmOpenRead); 1377 LFMMemStream:=TMemoryStream.Create; 1378 LRSMemStream:=TMemoryStream.Create; 1379 try 1380 LFMMemStream.SetSize(LFMFileStream.Size); 1381 LFMMemStream.CopyFrom(LFMFileStream,LFMFileStream.Size); 1382 LFMMemStream.Position:=0; 1383 LFMfilenameExt:=ExtractFileExt(LFMfilename); 1384 LRSfilename:=copy(LFMfilename,1, 1385 length(LFMfilename)-length(LFMfilenameExt))+'.lrs'; 1386 Result:=LFMtoLRSstream(LFMMemStream,LRSMemStream); 1387 if not Result then exit; 1388 LRSMemStream.Position:=0; 1389 LRSFileStream:=TFileStreamUTF8.Create(LRSfilename,fmCreate); 1390 try 1391 LRSFileStream.CopyFrom(LRSMemStream,LRSMemStream.Size); 1392 finally 1393 LRSFileStream.Free; 1394 end; 1395 finally 1396 LFMMemStream.Free; 1397 LRSMemStream.Free; 1398 LFMFileStream.Free; 1399 end; 1400 except 1401 on E: Exception do begin 1402 {$IFNDEF DisableChecks} 1403 DebugLn('LFMtoLRSfile ',E.Message); 1404 {$ENDIF} 1405 Result:=false; 1406 end; 1407 end; 1408end; 1409 1410function LFMtoLRSstream(LFMStream, LRSStream: TStream):boolean; 1411// returns true if successful 1412var FormClassName:ansistring; 1413 BinStream:TMemoryStream; 1414begin 1415 Result:=true; 1416 try 1417 FormClassName:=FindLFMClassName(LFMStream); 1418 BinStream:=TMemoryStream.Create; 1419 try 1420 LRSObjectTextToBinary(LFMStream,BinStream); 1421 BinStream.Position:=0; 1422 BinaryToLazarusResourceCode(BinStream,LRSStream,FormClassName,'FORMDATA'); 1423 finally 1424 BinStream.Free; 1425 end; 1426 except 1427 on E: Exception do begin 1428 {$IFNDEF DisableChecks} 1429 DebugLn('LFMtoLRSstream ',E.Message); 1430 {$ENDIF} 1431 Result:=false; 1432 end; 1433 end; 1434end; 1435 1436//============================================================================== 1437 1438{ TLResourceList } 1439 1440constructor TLResourceList.Create; 1441begin 1442 FList := TList.Create; 1443 FMergeList := TList.Create; 1444 FSortedCount := 0; 1445end; 1446 1447destructor TLResourceList.Destroy; 1448var 1449 a: integer; 1450begin 1451 for a := 0 to FList.Count - 1 do 1452 TLResource(FList[a]).Free; 1453 FList.Free; 1454 FMergeList.Free; 1455end; 1456 1457function TLResourceList.Count: integer; 1458begin 1459 if (Self<>nil) and (FList<>nil) then 1460 Result:=FList.Count 1461 else 1462 Result:=0; 1463end; 1464 1465procedure TLResourceList.Add(const Name, ValueType: AnsiString; 1466 const Values: array of string); 1467var 1468 NewLResource: TLResource; 1469 i, TotalLen, ValueCount, p: integer; 1470begin 1471 NewLResource := TLResource.Create; 1472 NewLResource.Name := Name; 1473 NewLResource.ValueType := uppercase(ValueType); 1474 1475 ValueCount := High(Values) - Low(Values) + 1; 1476 case ValueCount of 1477 0: 1478 begin 1479 NewLResource.Free; 1480 exit; 1481 end; 1482 1: 1483 NewLResource.Value:=Values[0]; 1484 else 1485 TotalLen := 0; 1486 for i := Low(Values) to High(Values) do 1487 inc(TotalLen, length(Values[i])); 1488 SetLength(NewLResource.Value, TotalLen); 1489 p := 1; 1490 for i := Low(Values) to High(Values) do 1491 begin 1492 if length(Values[i]) > 0 then 1493 begin 1494 Move(Values[i][1], NewLResource.Value[p], length(Values[i])); 1495 inc(p, length(Values[i])); 1496 end; 1497 end; 1498 end; 1499 1500 FList.Add(NewLResource); 1501end; 1502 1503function TLResourceList.Find(const Name: AnsiString):TLResource; 1504var 1505 P: Integer; 1506begin 1507 P := FindPosition(Name); 1508 if P >= 0 then 1509 Result := TLResource(FList[P]) 1510 else 1511 Result := nil; 1512end; 1513 1514function TLResourceList.Find(const Name, ValueType: AnsiString): TLResource; 1515var 1516 P, I: Integer; 1517begin 1518 P := FindPosition(Name); 1519 if P >= 0 then 1520 begin 1521 // Since we can have many resources that have the same name but different type 1522 // we should look before and after found position (do not forget that we are searching 1523 // them by dividing intervals) 1524 1525 // look before position 1526 for I := P - 1 downto 0 do 1527 begin 1528 Result := TLResource(FList[I]); 1529 if SysUtils.CompareText(Result.Name,Name)<>0 then 1530 break; 1531 if Result.ValueType = ValueType then 1532 Exit; 1533 end; 1534 // look behind position 1535 for I := P to FList.Count - 1 do 1536 begin 1537 Result := TLResource(FList[I]); 1538 if SysUtils.CompareText(Result.Name,Name)<>0 then 1539 break; 1540 if Result.ValueType = ValueType then 1541 Exit; 1542 end; 1543 end; 1544 Result := nil; 1545end; 1546 1547function TLResourceList.FindPosition(const Name: AnsiString): Integer; 1548var 1549 L, R, C: Integer; 1550begin 1551 if FSortedCount < FList.Count then 1552 Sort; 1553 L := 0; 1554 R := FList.Count-1; 1555 while (L <= R) do 1556 begin 1557 Result := (L + R) shr 1; 1558 C := SysUtils.CompareText(Name, TLResource(FList[Result]).Name); 1559 if C < 0 then 1560 R := Result - 1 1561 else 1562 if C > 0 then 1563 L := Result + 1 1564 else 1565 Exit; 1566 end; 1567 Result := -1; 1568end; 1569 1570function TLResourceList.GetItems(Index: integer): TLResource; 1571begin 1572 Result := TLResource(FList[Index]); 1573end; 1574 1575procedure TLResourceList.Sort; 1576{$IFNDEF DisableChecks} 1577var 1578 i: Integer; 1579 r1: TLResource; 1580 r2: TLResource; 1581{$ENDIF} 1582begin 1583 if FSortedCount = FList.Count then 1584 exit; 1585 // sort the unsorted elements 1586 FMergeList.Count := FList.Count; 1587 MergeSort(FList, FMergeList, FSortedCount, FList.Count - 1); 1588 // merge both 1589 Merge(FList, FMergeList, 0, FSortedCount, FList.Count - 1); 1590 FSortedCount := FList.Count; 1591 // check for doubles 1592 {$IFNDEF DisableChecks} 1593 for i:=0 to FList.Count-2 do 1594 begin 1595 r1:=TLResource(FList[i]); 1596 r2:=TLResource(FList[i+1]); 1597 if (SysUtils.CompareText(r1.Name,r2.Name)=0) and (r1.ValueType=r2.ValueType) then 1598 begin 1599 DebugLn(['TLResourceList.Sort ',i,' DUPLICATE RESOURCE FOUND: ',r1.Name,':',r1.ValueType]); 1600 //DumpStack; 1601 end; 1602 end; 1603 {$ENDIF} 1604end; 1605 1606procedure TLResourceList.MergeSort(List, MergeList: TList; Pos1, Pos2: integer); 1607var 1608 cmp, mid: integer; 1609begin 1610 if Pos1 = Pos2 then 1611 begin 1612 end else 1613 if Pos1 + 1 = Pos2 then 1614 begin 1615 cmp := SysUtils.CompareText(TLResource(List[Pos1]).Name, TLResource(List[Pos2]).Name); 1616 if cmp > 0 then 1617 begin 1618 MergeList[Pos1] := List[Pos1]; 1619 List[Pos1] := List[Pos2]; 1620 List[Pos2] := MergeList[Pos1]; 1621 end; 1622 end else 1623 begin 1624 if Pos2 > Pos1 then 1625 begin 1626 mid := (Pos1 + Pos2) shr 1; 1627 MergeSort(List, MergeList, Pos1, mid); 1628 MergeSort(List, MergeList, mid + 1, Pos2); 1629 Merge(List, MergeList, Pos1, mid + 1, Pos2); 1630 end; 1631 end; 1632end; 1633 1634procedure TLResourceList.Merge(List, MergeList: TList; Pos1, Pos2, Pos3: integer); 1635// merge two sorted arrays 1636// the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3 1637var 1638 Src1Pos, Src2Pos, DestPos, cmp, a: integer; 1639begin 1640 if (Pos1 >= Pos2) or (Pos2 > Pos3) then 1641 exit; 1642 Src1Pos := Pos2 - 1; 1643 Src2Pos := Pos3; 1644 DestPos := Pos3; 1645 while (Src2Pos >= Pos2) and (Src1Pos >= Pos1) do 1646 begin 1647 cmp:=SysUtils.CompareText(TLResource(List[Src1Pos]).Name, TLResource(List[Src2Pos]).Name); 1648 if cmp > 0 then 1649 begin 1650 MergeList[DestPos] := List[Src1Pos]; 1651 dec(Src1Pos); 1652 end else 1653 begin 1654 MergeList[DestPos] := List[Src2Pos]; 1655 dec(Src2Pos); 1656 end; 1657 dec(DestPos); 1658 end; 1659 while Src2Pos >= Pos2 do 1660 begin 1661 MergeList[DestPos] := List[Src2Pos]; 1662 dec(Src2Pos); 1663 dec(DestPos); 1664 end; 1665 for a := DestPos + 1 to Pos3 do 1666 List[a] := MergeList[a]; 1667end; 1668 1669procedure TLResourceList.Add(const Name, ValueType, Value: AnsiString); 1670begin 1671 Add(Name, ValueType, [Value]); 1672end; 1673 1674//------------------------------------------------------------------------------ 1675// Delphi object streams 1676 1677type 1678 TDelphiValueType = (dvaNull, dvaList, dvaInt8, dvaInt16, dvaInt32, dvaExtended, 1679 dvaString, dvaIdent, dvaFalse, dvaTrue, dvaBinary, dvaSet, dvaLString, 1680 dvaNil, dvaCollection, dvaSingle, dvaCurrency, dvaDate, dvaWString, 1681 dvaInt64, dvaUTF8String); 1682 1683 TDelphiReader = class 1684 private 1685 FStream: TStream; 1686 protected 1687 procedure SkipBytes(Count: Integer); 1688 procedure SkipSetBody; 1689 procedure SkipProperty; 1690 public 1691 constructor Create(Stream: TStream); 1692 procedure ReadSignature; 1693 procedure Read(out Buf; Count: Longint); 1694 function ReadInteger: Longint; 1695 function ReadValue: TDelphiValueType; 1696 function NextValue: TDelphiValueType; 1697 function ReadStr: string; 1698 function EndOfList: Boolean; 1699 procedure SkipValue; 1700 procedure CheckValue(Value: TDelphiValueType); 1701 procedure ReadListEnd; 1702 procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); virtual; 1703 function ReadFloat: Extended; 1704 function ReadSingle: Single; 1705 function ReadCurrency: Currency; 1706 function ReadDate: TDateTime; 1707 function ReadString: string; 1708 //function ReadWideString: WideString; 1709 function ReadInt64: Int64; 1710 function ReadIdent: string; 1711 end; 1712 1713 TDelphiWriter = class 1714 private 1715 FStream: TStream; 1716 public 1717 constructor Create(Stream: TStream); 1718 procedure Write(const Buf; Count: Longint); 1719 end; 1720 1721{ TDelphiReader } 1722 1723procedure ReadError(Msg: string); 1724begin 1725 raise EReadError.Create(Msg); 1726end; 1727 1728procedure PropValueError; 1729begin 1730 ReadError(rsInvalidPropertyValue); 1731end; 1732 1733procedure TDelphiReader.SkipBytes(Count: Integer); 1734begin 1735 FStream.Position:=FStream.Position+Count; 1736end; 1737 1738procedure TDelphiReader.SkipSetBody; 1739begin 1740 while ReadStr <> '' do ; 1741end; 1742 1743procedure TDelphiReader.SkipProperty; 1744begin 1745 ReadStr; { Skips property name } 1746 SkipValue; 1747end; 1748 1749constructor TDelphiReader.Create(Stream: TStream); 1750begin 1751 FStream:=Stream; 1752end; 1753 1754procedure TDelphiReader.ReadSignature; 1755var 1756 Signature: TFilerSignature; 1757begin 1758 Signature:='1234'; 1759 Read(Signature[1], length(Signature)); 1760 if Signature<>FilerSignature then 1761 ReadError(rsInvalidStreamFormat); 1762end; 1763 1764procedure TDelphiReader.Read(out Buf; Count: Longint); 1765begin 1766 FStream.Read(Buf,Count); 1767end; 1768 1769function TDelphiReader.ReadInteger: Longint; 1770var 1771 S: Shortint; 1772 I: Smallint; 1773begin 1774 case ReadValue of 1775 dvaInt8: 1776 begin 1777 Read(S, SizeOf(Shortint)); 1778 Result := S; 1779 end; 1780 dvaInt16: 1781 begin 1782 Read(I, SizeOf(I)); 1783 Result := I; 1784 end; 1785 dvaInt32: 1786 Read(Result, SizeOf(Result)); 1787 else 1788 Result:=0; 1789 PropValueError; 1790 end; 1791end; 1792 1793function TDelphiReader.ReadValue: TDelphiValueType; 1794var b: byte; 1795begin 1796 Read(b,1); 1797 Result:=TDelphiValueType(b); 1798end; 1799 1800function TDelphiReader.NextValue: TDelphiValueType; 1801begin 1802 Result := ReadValue; 1803 FStream.Position:=FStream.Position-1; 1804end; 1805 1806function TDelphiReader.ReadStr: string; 1807var 1808 L: Byte; 1809begin 1810 Read(L, SizeOf(Byte)); 1811 SetLength(Result, L); 1812 if L>0 then 1813 Read(Result[1], L); 1814end; 1815 1816function TDelphiReader.EndOfList: Boolean; 1817begin 1818 Result := (ReadValue = dvaNull); 1819 FStream.Position:=FStream.Position-1; 1820end; 1821 1822procedure TDelphiReader.SkipValue; 1823 1824 procedure SkipList; 1825 begin 1826 while not EndOfList do SkipValue; 1827 ReadListEnd; 1828 end; 1829 1830 procedure SkipBinary(BytesPerUnit: Integer); 1831 var 1832 Count: Longint; 1833 begin 1834 Read(Count, SizeOf(Count)); 1835 SkipBytes(Count * BytesPerUnit); 1836 end; 1837 1838 procedure SkipCollection; 1839 begin 1840 while not EndOfList do 1841 begin 1842 if NextValue in [dvaInt8, dvaInt16, dvaInt32] then SkipValue; 1843 SkipBytes(1); 1844 while not EndOfList do SkipProperty; 1845 ReadListEnd; 1846 end; 1847 ReadListEnd; 1848 end; 1849 1850begin 1851 case ReadValue of 1852 dvaNull: { no value field, just an identifier }; 1853 dvaList: SkipList; 1854 dvaInt8: SkipBytes(SizeOf(Byte)); 1855 dvaInt16: SkipBytes(SizeOf(Word)); 1856 dvaInt32: SkipBytes(SizeOf(LongInt)); 1857 dvaExtended: SkipBytes(SizeOf(Extended)); 1858 dvaString, dvaIdent: ReadStr; 1859 dvaFalse, dvaTrue: { no value field, just an identifier }; 1860 dvaBinary: SkipBinary(1); 1861 dvaSet: SkipSetBody; 1862 dvaLString: SkipBinary(1); 1863 dvaCollection: SkipCollection; 1864 dvaSingle: SkipBytes(Sizeof(Single)); 1865 dvaCurrency: SkipBytes(SizeOf(Currency)); 1866 dvaDate: SkipBytes(Sizeof(TDateTime)); 1867 dvaWString: SkipBinary(Sizeof(WideChar)); 1868 dvaInt64: SkipBytes(Sizeof(Int64)); 1869 dvaUTF8String: SkipBinary(1); 1870 end; 1871end; 1872 1873procedure TDelphiReader.CheckValue(Value: TDelphiValueType); 1874begin 1875 if ReadValue <> Value then 1876 begin 1877 FStream.Position:=FStream.Position-1; 1878 SkipValue; 1879 PropValueError; 1880 end; 1881end; 1882 1883procedure TDelphiReader.ReadListEnd; 1884begin 1885 CheckValue(dvaNull); 1886end; 1887 1888procedure TDelphiReader.ReadPrefix(var Flags: TFilerFlags; 1889 var AChildPos: Integer); 1890var 1891 Prefix: Byte; 1892begin 1893 Flags := []; 1894 if Byte(NextValue) and $F0 = $F0 then 1895 begin 1896 Prefix := Byte(ReadValue); 1897 if (Prefix and ObjStreamMaskInherited)>0 then 1898 Include(Flags,ffInherited); 1899 if (Prefix and ObjStreamMaskChildPos)>0 then 1900 Include(Flags,ffChildPos); 1901 if (Prefix and ObjStreamMaskInline)>0 then 1902 Include(Flags,ffInline); 1903 if ffChildPos in Flags then AChildPos := ReadInteger; 1904 end; 1905end; 1906 1907function TDelphiReader.ReadFloat: Extended; 1908begin 1909 if ReadValue = dvaExtended then 1910 Read(Result, SizeOf(Result)) 1911 else begin 1912 FStream.Position:=FStream.Position-1; 1913 Result := ReadInteger; 1914 end; 1915end; 1916 1917function TDelphiReader.ReadSingle: Single; 1918begin 1919 if ReadValue = dvaSingle then 1920 Read(Result, SizeOf(Result)) 1921 else begin 1922 FStream.Position:=FStream.Position-1; 1923 Result := ReadInteger; 1924 end; 1925end; 1926 1927function TDelphiReader.ReadCurrency: Currency; 1928begin 1929 if ReadValue = dvaCurrency then 1930 Read(Result, SizeOf(Result)) 1931 else begin 1932 FStream.Position:=FStream.Position-1; 1933 Result := ReadInteger; 1934 end; 1935end; 1936 1937function TDelphiReader.ReadDate: TDateTime; 1938begin 1939 if ReadValue = dvaDate then 1940 Read(Result, SizeOf(Result)) 1941 else begin 1942 FStream.Position:=FStream.Position-1; 1943 Result := ReadInteger; 1944 end; 1945end; 1946 1947function TDelphiReader.ReadString: string; 1948var 1949 L: Integer; 1950begin 1951 Result := ''; 1952 if NextValue in [dvaWString, dvaUTF8String] then begin 1953 ReadError('TDelphiReader.ReadString: WideString and UTF8String are not implemented yet'); 1954 //Result := ReadWideString; 1955 end else 1956 begin 1957 L := 0; 1958 case ReadValue of 1959 dvaString: 1960 Read(L, SizeOf(Byte)); 1961 dvaLString: 1962 Read(L, SizeOf(Integer)); 1963 else 1964 PropValueError; 1965 end; 1966 SetLength(Result, L); 1967 Read(Pointer(Result)^, L); 1968 end; 1969end; 1970 1971function TDelphiReader.ReadInt64: Int64; 1972begin 1973 if NextValue = dvaInt64 then 1974 begin 1975 ReadValue; 1976 Read(Result, Sizeof(Result)); 1977 end 1978 else 1979 Result := ReadInteger; 1980end; 1981 1982function TDelphiReader.ReadIdent: string; 1983var 1984 L: Byte; 1985begin 1986 case ReadValue of 1987 dvaIdent: 1988 begin 1989 Read(L, SizeOf(Byte)); 1990 SetLength(Result, L); 1991 Read(Result[1], L); 1992 end; 1993 dvaFalse: 1994 Result := 'False'; 1995 dvaTrue: 1996 Result := 'True'; 1997 dvaNil: 1998 Result := 'nil'; 1999 dvaNull: 2000 Result := 'Null'; 2001 else 2002 Result:=''; 2003 PropValueError; 2004 end; 2005end; 2006 2007{ TDelphiWriter } 2008 2009{ MultiByte Character Set (MBCS) byte type } 2010type 2011 TMbcsByteType = (mbSingleByte, mbLeadByte, mbTrailByte); 2012 2013function ByteType(const S: string; Index: Integer): TMbcsByteType; 2014begin 2015 Result := mbSingleByte; 2016 { ToDo: 2017 if SysLocale.FarEast then 2018 Result := ByteTypeTest(PChar(S), Index-1); 2019 } 2020end; 2021 2022constructor TDelphiWriter.Create(Stream: TStream); 2023begin 2024 FStream:=Stream; 2025end; 2026 2027procedure TDelphiWriter.Write(const Buf; Count: Longint); 2028begin 2029 FStream.Write(Buf,Count); 2030end; 2031 2032procedure ReadLFMHeader(LFMStream: TStream; 2033 out LFMType, LFMComponentName, LFMClassName: String); 2034var 2035 c:char; 2036 Token: String; 2037begin 2038 { examples: 2039 object Form1: TForm1 2040 inherited AboutBox2: TAboutBox2 2041 } 2042 LFMComponentName:=''; 2043 LFMClassName := ''; 2044 LFMType := ''; 2045 Token := ''; 2046 while (LFMStream.Read(c,1)=1) and (LFMStream.Position<1000) do begin 2047 if c in ['a'..'z','A'..'Z','0'..'9','_'] then 2048 Token := Token + c 2049 else begin 2050 if Token<>'' then begin 2051 if LFMType = '' then 2052 LFMType := Token 2053 else if LFMComponentName='' then 2054 LFMComponentName:=Token 2055 else if LFMClassName = '' then 2056 LFMClassName := Token; 2057 Token := ''; 2058 end; 2059 if c in [#10,#13] then break; 2060 end; 2061 end; 2062 LFMStream.Position:=0; 2063end; 2064 2065procedure ReadLFMHeader(const LFMSource: string; 2066 out LFMClassName: String; out LFMType: String); 2067var 2068 LFMComponentName: string; 2069begin 2070 ReadLFMHeader(LFMSource,LFMType,LFMComponentName,LFMClassName); 2071end; 2072 2073procedure ReadLFMHeader(const LFMSource: string; out LFMType, LFMComponentName, 2074 LFMClassName: String); 2075var 2076 p: Integer; 2077 StartPos: LongInt; 2078begin 2079 { examples: 2080 object Form1: TForm1 2081 inherited AboutBox2: TAboutBox2 2082 2083 - LFMType is the first word on the line 2084 - LFMComponentName is the second word 2085 - LFMClassName is the fourth token 2086 } 2087 2088 // read first word => LFMType 2089 p:=1; 2090 while (p<=length(LFMSource)) 2091 and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_']) do 2092 inc(p); 2093 LFMType:=copy(LFMSource,1,p-1); 2094 2095 // read second word => LFMComponentName 2096 while (p<=length(LFMSource)) and (LFMSource[p] in [' ',#9]) do inc(p); 2097 StartPos:=p; 2098 while (p<=length(LFMSource)) 2099 and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_']) do 2100 inc(p); 2101 LFMComponentName:=copy(LFMSource,StartPos,p-StartPos); 2102 2103 // read third word => LFMClassName 2104 while (p<=length(LFMSource)) and (LFMSource[p] in [' ',#9,':']) do inc(p); 2105 StartPos:=p; 2106 while (p<=length(LFMSource)) 2107 and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_']) do 2108 inc(p); 2109 LFMClassName:=copy(LFMSource,StartPos,p-StartPos); 2110end; 2111 2112function ReadLFMHeaderFromFile(const Filename: string; out LFMType, 2113 LFMComponentName, LFMClassName: String): boolean; 2114var 2115 fs: TFileStreamUTF8; 2116 Header: string; 2117 Cnt: LongInt; 2118begin 2119 Result:=false; 2120 try 2121 fs:=TFileStreamUTF8.Create(Filename,fmOpenRead); 2122 try 2123 SetLength(Header,600); 2124 Cnt:=fs.Read(Header[1],length(Header)); 2125 SetLength(Header,Cnt); 2126 ReadLFMHeader(Header,LFMType,LFMComponentName,LFMClassName); 2127 Result:=LFMClassName<>''; 2128 finally 2129 fs.Free; 2130 end; 2131 except 2132 end; 2133end; 2134 2135function CreateLFMFile(AComponent: TComponent; LFMStream: TStream): integer; 2136// 0 = ok 2137// -1 = error while streaming AForm to binary stream 2138// -2 = error while streaming binary stream to text file 2139var 2140 BinStream: TMemoryStream; 2141 DestroyDriver: Boolean; 2142 Writer: TWriter; 2143begin 2144 Result:=0; 2145 BinStream:=TMemoryStream.Create; 2146 try 2147 try 2148 // write component to binary stream 2149 DestroyDriver:=false; 2150 Writer:=CreateLRSWriter(BinStream,DestroyDriver); 2151 try 2152 Writer.WriteDescendent(AComponent,nil); 2153 finally 2154 if DestroyDriver then Writer.Driver.Free; 2155 Writer.Free; 2156 end; 2157 except 2158 Result:=-1; 2159 exit; 2160 end; 2161 try 2162 // transform binary to text 2163 BinStream.Position:=0; 2164 LRSObjectBinaryToText(BinStream,LFMStream); 2165 except 2166 Result:=-2; 2167 exit; 2168 end; 2169 finally 2170 BinStream.Free; 2171 end; 2172end; 2173 2174procedure LRSObjectBinaryToText(Input, Output: TStream); 2175 2176 procedure OutStr(const s: String); 2177 {$IFDEF VerboseLRSObjectBinaryToText} 2178 var 2179 i: Integer; 2180 {$ENDIF} 2181 begin 2182 {$IFDEF VerboseLRSObjectBinaryToText} 2183 for i:=1 to length(s) do begin 2184 if (s[i] in [#0..#8,#11..#12,#14..#31]) then begin 2185 DbgOut('#'+IntToStr(ord(s[i]))); 2186 RaiseGDBException('ObjectLRSToText: Invalid character'); 2187 end else 2188 DbgOut(s[i]); 2189 end; 2190 {$ENDIF} 2191 if Length(s) > 0 then 2192 Output.Write(s[1], Length(s)); 2193 end; 2194 2195 procedure OutLn(const s: String); 2196 begin 2197 OutStr(s + LineEnding); 2198 end; 2199 2200 procedure OutString(const s: String); 2201 var 2202 res, NewStr: String; 2203 i: Integer; 2204 InString, NewInString: Boolean; 2205 begin 2206 if s<>'' then begin 2207 res := ''; 2208 InString := False; 2209 for i := 1 to Length(s) do begin 2210 NewInString := InString; 2211 case s[i] of 2212 #0..#31: begin 2213 NewInString := False; 2214 NewStr := '#' + IntToStr(Ord(s[i])); 2215 end; 2216 '''': begin 2217 NewInString := True; 2218 NewStr:=''''''; // write two ticks, so the reader will read one 2219 end; 2220 else begin 2221 NewInString := True; 2222 NewStr := s[i]; 2223 end; 2224 end; 2225 if NewInString <> InString then begin 2226 NewStr := '''' + NewStr; 2227 InString := NewInString; 2228 end; 2229 res := res + NewStr; 2230 end; 2231 if InString then res := res + ''''; 2232 end else begin 2233 res:=''''''; 2234 end; 2235 OutStr(res); 2236 end; 2237 2238 procedure OutWideString(const s: WideString); 2239 // write as normal string 2240 var 2241 res, NewStr: String; 2242 i: Integer; 2243 InString, NewInString: Boolean; 2244 begin 2245 //debugln('OutWideString ',s); 2246 res := ''; 2247 if s<>'' then begin 2248 InString := False; 2249 for i := 1 to Length(s) do begin 2250 NewInString := InString; 2251 if (ord(s[i])<ord(' ')) or (ord(s[i])>=127) then begin 2252 // special char 2253 NewInString := False; 2254 NewStr := '#' + IntToStr(Ord(s[i])); 2255 end 2256 else if s[i]='''' then begin 2257 // ' 2258 if InString then 2259 NewStr := '''''' 2260 else 2261 NewStr := ''''''''; 2262 end 2263 else begin 2264 // normal char 2265 NewInString := True; 2266 NewStr := AnsiString(s[i]); 2267 end; 2268 if NewInString <> InString then begin 2269 NewStr := '''' + NewStr; 2270 InString := NewInString; 2271 end; 2272 res := res + NewStr; 2273 end; 2274 if InString then res := res + ''''; 2275 end else begin 2276 res:=''''''; 2277 end; 2278 OutStr(res); 2279 end; 2280 2281 function ReadInt(ValueType: TValueType): LongInt; 2282 var 2283 w: Word; 2284 begin 2285 case ValueType of 2286 vaInt8: Result := ShortInt(Input.ReadByte); 2287 vaInt16: begin 2288 w:=ReadLRSWord(Input); 2289 //DebugLn('ReadInt vaInt16 w=',IntToStr(w)); 2290 Result := SmallInt(w); 2291 end; 2292 vaInt32: Result := ReadLRSInteger(Input); 2293 else Result := 0; 2294 end; 2295 end; 2296 2297 function ReadInt: LongInt; 2298 begin 2299 Result := ReadInt(TValueType(Input.ReadByte)); 2300 end; 2301 2302 function ReadShortString: String; 2303 var 2304 len: Byte; 2305 begin 2306 len := Input.ReadByte; 2307 SetLength(Result, len); 2308 if (Len > 0) then 2309 Input.Read(Result[1], len); 2310 end; 2311 2312 function ReadLongString: String; 2313 var 2314 len: integer; 2315 begin 2316 len := ReadLRSInteger(Input); 2317 SetLength(Result, len); 2318 if (Len > 0) then 2319 Input.Read(Result[1], len); 2320 end; 2321 2322 procedure ReadPropList(const indent: String); 2323 2324 procedure ProcessValue(ValueType: TValueType; const Indent: String); 2325 2326 procedure Stop(const s: String); 2327 begin 2328 RaiseGDBException('ObjectLRSToText '+s); 2329 end; 2330 2331 function ValueTypeAsString(ValueType: TValueType): string; 2332 begin 2333 case ValueType of 2334 vaNull: Result:='vaNull'; 2335 vaList: Result:='vaList'; 2336 vaInt8: Result:='vaInt8'; 2337 vaInt16: Result:='vaInt16'; 2338 vaInt32: Result:='vaInt32'; 2339 vaExtended: Result:='vaExtended'; 2340 vaString: Result:='vaString'; 2341 vaIdent: Result:='vaIdent'; 2342 vaFalse: Result:='vaFalse'; 2343 vaTrue: Result:='vaTrue'; 2344 vaBinary: Result:='vaBinary'; 2345 vaSet: Result:='vaSet'; 2346 vaLString: Result:='vaLString'; 2347 vaNil: Result:='vaNil'; 2348 vaCollection: Result:='vaCollection'; 2349 vaSingle: Result:='vaSingle'; 2350 vaCurrency: Result:='vaCurrency'; 2351 vaDate: Result:='vaDate'; 2352 vaWString: Result:='vaWString'; 2353 vaInt64: Result:='vaInt64'; 2354 vaUTF8String: Result:='vaUTF8String'; 2355 vaUString: Result:='vaUString'; 2356 vaQWord : Result:='vaQWord'; 2357 else Result:='Unknown ValueType='+dbgs(Ord(ValueType)); 2358 end; 2359 end; 2360 2361 procedure UnknownValueType; 2362 var 2363 s: String; 2364 {$IFNDEF DisableChecks} 2365 HintStr: string; 2366 HintLen: Int64; 2367 {$ENDIF} 2368 begin 2369 s:=ValueTypeAsString(ValueType); 2370 if s<>'' then 2371 s:='Unimplemented ValueType='+s; 2372 {$IFNDEF DisableChecks} 2373 HintLen:=Output.Position; 2374 if HintLen>50 then HintLen:=50; 2375 SetLength(HintStr,HintLen); 2376 if HintStr<>'' then begin 2377 try 2378 Output.Position:=Output.Position-length(HintStr); 2379 Output.Read(HintStr[1],length(HintStr)); 2380 //debugln('ObjectLRSToText:'); 2381 debugln(DbgStr(HintStr)); 2382 except 2383 end; 2384 end; 2385 {$ENDIF} 2386 s:=s+' '; 2387 Stop(s); 2388 end; 2389 2390 procedure ProcessBinary; 2391 var 2392 ToDo, DoNow, StartPos, i: LongInt; 2393 lbuf: array[0..31] of Byte; 2394 s: String; 2395 p: pchar; 2396 const 2397 HexDigits: array[0..$F] of char = '0123456789ABCDEF'; 2398 begin 2399 ToDo := ReadLRSCardinal(Input); 2400 OutLn('{'); 2401 while ToDo > 0 do begin 2402 DoNow := ToDo; 2403 if DoNow > 32 then DoNow := 32; 2404 Dec(ToDo, DoNow); 2405 s := Indent + ' '; 2406 StartPos := length(s); 2407 Input.Read(lbuf, DoNow); 2408 setlength(s, StartPos+DoNow*2); 2409 p := @s[StartPos]; 2410 for i := 0 to DoNow - 1 do begin 2411 inc(p); 2412 p^ := HexDigits[(lbuf[i] shr 4) and $F]; 2413 inc(p); 2414 p^ := HexDigits[lbuf[i] and $F]; 2415 end; 2416 OutLn(s); 2417 end; 2418 OutStr(indent); 2419 OutLn('}'); 2420 end; 2421 2422 var 2423 s: String; 2424 IsFirst: Boolean; 2425 ext: Extended; 2426 ASingle: single; 2427 ADate: TDateTime; 2428 ACurrency: Currency; 2429 AWideString: WideString; 2430 2431 begin 2432 //DebugLn(['ProcessValue ',Indent,' ValueType="',ValueTypeAsString(ValueType),'"']); 2433 case ValueType of 2434 vaList: begin 2435 OutStr('('); 2436 IsFirst := True; 2437 while True do begin 2438 ValueType := TValueType(Input.ReadByte); 2439 if ValueType = vaNull then break; 2440 if IsFirst then begin 2441 OutLn(''); 2442 IsFirst := False; 2443 end; 2444 OutStr(Indent + ' '); 2445 ProcessValue(ValueType, Indent + ' '); 2446 end; 2447 OutLn(Indent + ')'); 2448 end; 2449 vaInt8: begin 2450 // MG: IntToStr has a bug with ShortInt, therefore these typecasts 2451 OutLn(IntToStr(Integer(ShortInt(Input.ReadByte)))); 2452 end; 2453 vaInt16: OutLn(IntToStr(SmallInt(ReadLRSWord(Input)))); 2454 vaInt32: OutLn(IntToStr(ReadLRSInteger(Input))); 2455 vaInt64: OutLn(IntToStr(ReadLRSInt64(Input))); 2456 vaExtended: begin 2457 ext:=ReadLRSExtended(Input); 2458 OutLn(FloatToStr(ext)); 2459 end; 2460 vaString: begin 2461 OutString(ReadShortString); 2462 OutLn(''); 2463 end; 2464 vaIdent: OutLn(ReadShortString); 2465 vaFalse: OutLn('False'); 2466 vaTrue: OutLn('True'); 2467 vaBinary: ProcessBinary; 2468 vaSet: begin 2469 OutStr('['); 2470 IsFirst := True; 2471 while True do begin 2472 s := ReadShortString; 2473 if Length(s) = 0 then break; 2474 if not IsFirst then OutStr(', '); 2475 IsFirst := False; 2476 OutStr(s); 2477 end; 2478 OutLn(']'); 2479 end; 2480 vaLString: begin 2481 OutString(ReadLongString); 2482 OutLn(''); 2483 end; 2484 vaNil: 2485 OutLn('nil'); 2486 vaCollection: begin 2487 OutStr('<'); 2488 while Input.ReadByte <> 0 do begin 2489 OutLn(Indent); 2490 Input.Seek(-1, soFromCurrent); 2491 OutStr(indent + ' item'); 2492 ValueType := TValueType(Input.ReadByte); 2493 if ValueType <> vaList then 2494 OutStr('[' + IntToStr(ReadInt(ValueType)) + ']'); 2495 OutLn(''); 2496 ReadPropList(indent + ' '); 2497 OutStr(indent + ' end'); 2498 end; 2499 OutLn('>'); 2500 end; 2501 vaSingle: begin 2502 ASingle:=ReadLRSSingle(Input); 2503 OutLn(FloatToStr(ASingle) + 's'); 2504 end; 2505 vaDate: begin 2506 ADate:=TDateTime(ReadLRSDouble(Input)); 2507 OutLn(FloatToStr(ADate) + 'd'); 2508 end; 2509 vaCurrency: begin 2510 ACurrency:=ReadLRSCurrency(Input); 2511 OutLn(FloatToStr(ACurrency * 10000) + 'c'); 2512 end; 2513 vaWString,vaUString: begin 2514 AWideString:=ReadLRSWideString(Input); 2515 OutWideString(AWideString); 2516 OutLn(''); 2517 end; 2518 else 2519 if ord(ValueType)=20 then begin 2520 // vaUTF8String 2521 // Delphi saves widestrings as UTF8 strings 2522 // The LCL does not use widestrings, but UTF8 directly 2523 // so, simply read and write the string 2524 OutString(ReadLongString); 2525 OutLn(''); 2526 end else 2527 UnknownValueType; 2528 end; 2529 end; 2530 2531 var 2532 NextByte: Byte; 2533 begin 2534 while Input.ReadByte <> 0 do begin 2535 Input.Seek(-1, soFromCurrent); 2536 OutStr(indent + ReadShortString + ' = '); 2537 NextByte:=Input.ReadByte; 2538 if NextByte<>0 then 2539 ProcessValue(TValueType(NextByte), Indent) 2540 else 2541 OutLn(''); 2542 end; 2543 end; 2544 2545 procedure ReadObject(const indent: String); 2546 var 2547 b: Byte; 2548 ObjClassName, ObjName: String; 2549 ChildPos: LongInt; 2550 begin 2551 ChildPos := 0; 2552 // Check for FilerFlags 2553 b := Input.ReadByte; 2554 if (b and $f0) = $f0 then begin 2555 if (b and ObjStreamMaskChildPos) <> 0 then 2556 ChildPos := ReadInt; 2557 end else begin 2558 b := 0; 2559 Input.Seek(-1, soFromCurrent); 2560 end; 2561 2562 ObjClassName := ReadShortString; 2563 ObjName := ReadShortString; 2564 2565 OutStr(Indent); 2566 if (b and ObjStreamMaskInherited) <> 0 then OutStr('inherited') 2567 else if (b and ObjStreamMaskInline) <> 0 then OutStr('inline') 2568 else OutStr('object'); 2569 OutStr(' '); 2570 if ObjName <> '' then 2571 OutStr(ObjName + ': '); 2572 OutStr(ObjClassName); 2573 if (b and ObjStreamMaskChildPos) <> 0 then OutStr('[' + IntToStr(ChildPos) + ']'); 2574 OutLn(''); 2575 2576 ReadPropList(indent + ' '); 2577 2578 while Input.ReadByte <> 0 do begin 2579 Input.Seek(-1, soFromCurrent); 2580 ReadObject(indent + ' '); 2581 end; 2582 OutLn(indent + 'end'); 2583 end; 2584 2585var 2586 OldDecimalSeparator: Char; 2587 OldThousandSeparator: Char; 2588 Signature: TFilerSignature; 2589begin 2590 // Endian note: comparing 2 cardinals is endian independent 2591 Signature:='1234'; 2592 Input.Read(Signature[1], length(Signature)); 2593 if Signature<>FilerSignature then 2594 raise EReadError.Create('Illegal stream image' {###SInvalidImage}); 2595 OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator; 2596 DefaultFormatSettings.DecimalSeparator:='.'; 2597 OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator; 2598 DefaultFormatSettings.ThousandSeparator:=','; 2599 try 2600 ReadObject(''); 2601 finally 2602 DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator; 2603 DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator; 2604 end; 2605end; 2606 2607function TestFormStreamFormat(Stream: TStream): TLRSStreamOriginalFormat; 2608var 2609 Pos: TStreamSeekType; 2610 Signature: TFilerSignature; 2611begin 2612 Pos := Stream.Position; 2613 Signature[1] := #0; // initialize, in case the stream is at its end 2614 Stream.Read(Signature, length(Signature)); 2615 Stream.Position := Pos; 2616 if (Signature[1] = #$FF) or (Signature = FilerSignature) then 2617 Result := sofBinary 2618 // text format may begin with "object", "inherited", or whitespace 2619 else if Signature[1] in ['o','O','i','I',' ',#13,#11,#9] then 2620 Result := sofText 2621 else 2622 Result := sofUnknown; 2623end; 2624 2625type 2626 TObjectTextConvertProc = procedure (Input, Output: TStream); 2627 2628procedure InternalLRSBinaryToText(Input, Output: TStream; 2629 var OriginalFormat: TLRSStreamOriginalFormat; 2630 ConvertProc: TObjectTextConvertProc; 2631 BinarySignature: TFilerSignature); 2632var 2633 Pos: TStreamSeekType; 2634 Signature: TFilerSignature; 2635begin 2636 Pos := Input.Position; 2637 Signature := BinarySignature; 2638 Signature[1]:=#0; 2639 Input.Read(Signature[1], length(Signature)); 2640 Input.Position := Pos; 2641 if Signature = BinarySignature then 2642 begin // definitely binary format 2643 if OriginalFormat = sofBinary then begin 2644 if Output is TMemoryStream then 2645 TMemoryStream(Output).SetSize(Output.Position+(Input.Size-Input.Position)); 2646 Output.CopyFrom(Input, Input.Size - Input.Position) 2647 end else 2648 begin 2649 if OriginalFormat = sofUnknown then 2650 Originalformat := sofBinary; 2651 ConvertProc(Input, Output); 2652 end; 2653 end 2654 else // might be text format 2655 begin 2656 if OriginalFormat = sofBinary then 2657 ConvertProc(Input, Output) 2658 else 2659 begin 2660 if OriginalFormat = sofUnknown then 2661 begin // text format may begin with "object", "inherited", or whitespace 2662 if Signature[1] in ['o','O','i','I',' ',#13,#11,#9] then 2663 OriginalFormat := sofText 2664 else // not binary, not text... let it raise the exception 2665 begin 2666 ConvertProc(Input, Output); 2667 Exit; 2668 end; 2669 end; 2670 if OriginalFormat = sofText then begin 2671 if Output is TMemoryStream then 2672 TMemoryStream(Output).SetSize(Output.Position 2673 +(Input.Size - Input.Position)); 2674 Output.CopyFrom(Input, Input.Size - Input.Position); 2675 end; 2676 end; 2677 end; 2678end; 2679 2680procedure LRSObjectTextToBinary(Input, Output: TStream; Links: TLRPositionLinks); 2681var 2682 parser: {$IFDEF DisableWindowsUnicodeSupport}TParser{$ELSE}TUTF8Parser{$ENDIF}; 2683 OldDecimalSeparator: Char; 2684 OldThousandSeparator: Char; 2685 TokenStartPos: LongInt; 2686 2687 procedure WriteShortString(const s: String); 2688 var 2689 Size: Integer; 2690 begin 2691 Size:=length(s); 2692 if Size>255 then Size:=255; 2693 Output.WriteByte(byte(Size)); 2694 if Size > 0 then 2695 Output.Write(s[1], Size); 2696 end; 2697 2698 procedure WriteLongString(const s: String); 2699 begin 2700 WriteLRSInteger(Output,Length(s)); 2701 if Length(s) > 0 then 2702 Output.Write(s[1], Length(s)); 2703 end; 2704 2705 procedure WriteWideString(const s: WideString); 2706 begin 2707 WriteLRSInteger(Output,Length(s)); 2708 if Length(s) > 0 then 2709 Output.Write(s[1], Length(s)*2); 2710 end; 2711 2712 procedure WriteInteger(value: LongInt); 2713 begin 2714 if (value >= -128) and (value <= 127) then begin 2715 Output.WriteByte(Ord(vaInt8)); 2716 Output.WriteByte(Byte(value)); 2717 end else if (value >= -32768) and (value <= 32767) then begin 2718 Output.WriteByte(Ord(vaInt16)); 2719 WriteLRSWord(Output,Word(value)); 2720 end else begin 2721 Output.WriteByte(ord(vaInt32)); 2722 WriteLRSInteger(Output,value); 2723 end; 2724 end; 2725 2726 procedure WriteInt64(const Value: Int64); 2727 begin 2728 if (Value >= -$80000000) and (Value <= $7fffffff) then 2729 WriteInteger(Integer(Value)) 2730 else begin 2731 Output.WriteByte(ord(vaInt64)); 2732 WriteLRSInt64(Output,Value); 2733 end; 2734 end; 2735 2736 procedure WriteIntegerStr(const s: string); 2737 begin 2738 if length(s)>7 then 2739 WriteInt64(StrToInt64(s)) 2740 else 2741 WriteInteger(StrToInt(s)); 2742 end; 2743 2744 {$IFDEF DisableWindowsUnicodeSupport} 2745 function WideStringNeeded(const s: widestring): Boolean; 2746 var 2747 i: Integer; 2748 begin 2749 i:=length(s); 2750 while (i>=1) and (ord(s[i])<256) do dec(i); 2751 Result:=i>=1; 2752 end; 2753 2754 function WideStrToAnsiStrWithoutConversion(const s: widestring): string; 2755 var 2756 i: Integer; 2757 begin 2758 SetLength(Result,Length(s){$IFDEF WideStringLenDoubled} div 2{$ENDIF}); 2759 for i:=1 to length(Result) do 2760 Result[i]:=chr(ord(s[i])); 2761 end; 2762 2763 function WideStrToShortStrWithoutConversion(const s: widestring): shortstring; 2764 var 2765 i: Integer; 2766 begin 2767 SetLength(Result,Length(s){$IFDEF WideStringLenDoubled} div 2{$ENDIF}); 2768 for i:=1 to length(Result) do 2769 Result[i]:=chr(ord(s[i])); 2770 end; 2771 {$ENDIF} 2772 2773 function ParserNextToken: Char; 2774 begin 2775 TokenStartPos:=Parser.SourcePos; 2776 Result:=Parser.NextToken; 2777 if Links<>nil then 2778 Links.SetPosition(TokenStartPos,Parser.SourcePos,Output.Position,true); 2779 end; 2780 2781 procedure ProcessProperty; forward; 2782 2783 {$if not declared(toWString)} 2784 const toWString = char(5); 2785 {$endif} 2786 2787 procedure ProcessValue; 2788 2789 procedure RaiseValueExpected; 2790 begin 2791 parser.Error('Value expected, but '+parser.TokenString+' found'); 2792 end; 2793 2794 var 2795 flt: Extended; 2796 stream: TMemoryStream; 2797 BinDataSize: LongInt; 2798 toStringBuf: String; 2799 begin 2800 if parser.TokenSymbolIs('END') then exit; 2801 if parser.TokenSymbolIs('OBJECT') then 2802 RaiseValueExpected; 2803 case parser.Token of 2804 toInteger: 2805 begin 2806 WriteIntegerStr(parser.TokenString); 2807 ParserNextToken; 2808 end; 2809 toFloat: 2810 begin 2811 flt := Parser.TokenFloat; 2812 case parser.FloatType of 2813 's': begin 2814 Output.WriteByte(Ord(vaSingle)); 2815 WriteLRSSingle(Output,flt); 2816 end; 2817 'd': begin 2818 Output.WriteByte(Ord(vaDate)); 2819 WriteLRSDouble(Output,flt); 2820 end; 2821 'c': begin 2822 Output.WriteByte(Ord(vaCurrency)); 2823 WriteLRSCurrency(Output,flt/10000); 2824 end; 2825 else 2826 begin 2827 Output.WriteByte(Ord(vaExtended)); 2828 WriteLRSExtended(Output,flt); 2829 end; 2830 end; 2831 ParserNextToken; 2832 end; 2833 toString: 2834 begin 2835 toStringBuf := parser.TokenString; 2836 //DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]); 2837 while ParserNextToken = '+' do 2838 begin 2839 ParserNextToken; // Get next string fragment 2840 if not (parser.Token in [toString,toWString]) then 2841 parser.CheckToken(toString); 2842 toStringBuf := toStringBuf + parser.TokenString; 2843 end; 2844 if length(toStringBuf)<256 then begin 2845 //debugln('LRSObjectTextToBinary.ProcessValue WriteShortString'); 2846 Output.WriteByte(Ord(vaString)); 2847 WriteShortString(toStringBuf); 2848 end else begin 2849 //debugln('LRSObjectTextToBinary.ProcessValue WriteLongString'); 2850 Output.WriteByte(Ord(vaLString)); 2851 WriteLongString(toStringBuf); 2852 end; 2853 end; 2854 toWString: 2855 begin 2856 toStringBuf := parser.TokenString; 2857 //DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]); 2858 while ParserNextToken = '+' do 2859 begin 2860 ParserNextToken; // Get next string fragment 2861 if not (parser.Token in [toString,toWString]) then 2862 parser.CheckToken(toString); 2863 toStringBuf := toStringBuf + parser.TokenString; 2864 end; 2865 Output.WriteByte(Ord(vaWString)); 2866 WriteWideString(UTF8Decode(toStringBuf)); 2867 end; 2868 toSymbol: 2869 begin 2870 if CompareText(parser.TokenString, 'True') = 0 then 2871 Output.WriteByte(Ord(vaTrue)) 2872 else if CompareText(parser.TokenString, 'False') = 0 then 2873 Output.WriteByte(Ord(vaFalse)) 2874 else if CompareText(parser.TokenString, 'nil') = 0 then 2875 Output.WriteByte(Ord(vaNil)) 2876 else 2877 begin 2878 Output.WriteByte(Ord(vaIdent)); 2879 WriteShortString(parser.TokenComponentIdent); 2880 end; 2881 ParserNextToken; 2882 end; 2883 // Set 2884 '[': 2885 begin 2886 ParserNextToken; 2887 Output.WriteByte(Ord(vaSet)); 2888 if parser.Token <> ']' then 2889 while True do 2890 begin 2891 parser.CheckToken(toSymbol); 2892 WriteShortString(parser.TokenString); 2893 ParserNextToken; 2894 if parser.Token = ']' then 2895 break; 2896 parser.CheckToken(','); 2897 ParserNextToken; 2898 end; 2899 Output.WriteByte(0); 2900 ParserNextToken; 2901 end; 2902 // List 2903 '(': 2904 begin 2905 Output.WriteByte(Ord(vaList)); 2906 ParserNextToken; 2907 while parser.Token <> ')' do 2908 ProcessValue; 2909 Output.WriteByte(0); 2910 ParserNextToken; 2911 end; 2912 // Collection 2913 '<': 2914 begin 2915 ParserNextToken; 2916 Output.WriteByte(Ord(vaCollection)); 2917 while parser.Token <> '>' do 2918 begin 2919 parser.CheckTokenSymbol('item'); 2920 ParserNextToken; 2921 // ConvertOrder 2922 Output.WriteByte(Ord(vaList)); 2923 while not parser.TokenSymbolIs('end') do 2924 ProcessProperty; 2925 ParserNextToken; // Skip 'end' 2926 Output.WriteByte(0); 2927 end; 2928 Output.WriteByte(0); 2929 ParserNextToken; 2930 end; 2931 // Binary data 2932 '{': 2933 begin 2934 Output.WriteByte(Ord(vaBinary)); 2935 stream := TMemoryStream.Create; 2936 try 2937 parser.HexToBinary(stream); 2938 BinDataSize:=integer(stream.Size); 2939 WriteLRSInteger(Output,BinDataSize); 2940 Output.Write(Stream.Memory^, BinDataSize); 2941 Stream.Position:=0; 2942 //debugln('LRSObjectTextToBinary binary data "',dbgMemStream(Stream,30),'"'); 2943 finally 2944 stream.Free; 2945 end; 2946 ParserNextToken; 2947 end; 2948 else 2949 parser.Error('Invalid Property'); 2950 end; 2951 end; 2952 2953 procedure ProcessProperty; 2954 var 2955 name: String; 2956 begin 2957 // Get name of property 2958 parser.CheckToken(toSymbol); 2959 name := parser.TokenString; 2960 while True do begin 2961 ParserNextToken; 2962 if parser.Token <> '.' then break; 2963 ParserNextToken; 2964 parser.CheckToken(toSymbol); 2965 name := name + '.' + parser.TokenString; 2966 end; 2967 WriteShortString(name); 2968 parser.CheckToken('='); 2969 ParserNextToken; 2970 ProcessValue; 2971 end; 2972 2973 procedure ProcessObject; 2974 var 2975 Flags: Byte; 2976 ChildPos: Integer; 2977 ObjectName, ObjectType: String; 2978 begin 2979 if parser.TokenSymbolIs('OBJECT') then 2980 Flags :=0 { IsInherited := False } 2981 else if parser.TokenSymbolIs('INHERITED') then 2982 Flags := 1 { IsInherited := True; } 2983 else begin 2984 parser.CheckTokenSymbol('INLINE'); 2985 Flags := 4; 2986 end; 2987 ParserNextToken; 2988 parser.CheckToken(toSymbol); 2989 if parser.TokenSymbolIs('END') then begin 2990 // 'object end': no name, no content 2991 // this is normally invalid, but Delphi can create this, so ignore it 2992 exit; 2993 end; 2994 ObjectName := ''; 2995 ObjectType := parser.TokenString; 2996 ParserNextToken; 2997 ChildPos := 0; 2998 if parser.Token = ':' then begin 2999 ParserNextToken; 3000 parser.CheckToken(toSymbol); 3001 ObjectName := ObjectType; 3002 ObjectType := parser.TokenString; 3003 ParserNextToken; 3004 if parser.Token = '[' then begin 3005 ParserNextToken; 3006 ChildPos := parser.TokenInt; 3007 ParserNextToken; 3008 parser.CheckToken(']'); 3009 ParserNextToken; 3010 Flags := Flags or 2; 3011 end; 3012 end; 3013 if Flags <> 0 then begin 3014 Output.WriteByte($f0 or Flags); 3015 if (Flags and ObjStreamMaskChildPos) <> 0 then 3016 WriteInteger(ChildPos); 3017 end; 3018 WriteShortString(ObjectType); 3019 WriteShortString(ObjectName); 3020 3021 // Convert property list 3022 while not (parser.TokenSymbolIs('END') or 3023 parser.TokenSymbolIs('OBJECT') or 3024 parser.TokenSymbolIs('INHERITED') or 3025 parser.TokenSymbolIs('INLINE')) 3026 do 3027 ProcessProperty; 3028 Output.WriteByte(0); // Terminate property list 3029 3030 // Convert child objects 3031 while not parser.TokenSymbolIs('END') do ProcessObject; 3032 ParserNextToken; // Skip end token 3033 Output.WriteByte(0); // Terminate property list 3034 end; 3035 3036var 3037 Count: Integer; 3038begin 3039 if Links<>nil then begin 3040 // sort links for LFM positions 3041 Links.Sort(true); 3042 end; 3043 parser := {$IFDEF DisableWindowsUnicodeSupport}TParser{$ELSE}TUTF8Parser{$ENDIF}.Create(Input); 3044 OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator; 3045 DefaultFormatSettings.DecimalSeparator:='.'; 3046 OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator; 3047 DefaultFormatSettings.ThousandSeparator:=','; 3048 try 3049 Count:=0; 3050 repeat 3051 Output.Write(FilerSignature[1], length(FilerSignature)); 3052 ProcessObject; 3053 inc(Count); 3054 until parser.TokenString=''; 3055 if Count>1 then 3056 Output.WriteByte(0); // Terminate object list 3057 finally 3058 parser.Free; 3059 DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator; 3060 DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator; 3061 end; 3062end; 3063 3064procedure LRSObjectToText(Input, Output: TStream; 3065 var OriginalFormat: TLRSStreamOriginalFormat); 3066begin 3067 InternalLRSBinaryToText(Input, Output, OriginalFormat, 3068 @LRSObjectBinaryToText, FilerSignature); 3069end; 3070 3071procedure LRSObjectResToText(Input, Output: TStream; 3072 var OriginalFormat: TLRSStreamOriginalFormat); 3073begin 3074 InternalLRSBinaryToText(Input, Output, OriginalFormat, 3075 @LRSObjectResourceToText, #255); 3076end; 3077 3078procedure LRSObjectResourceToText(Input, Output: TStream); 3079begin 3080 Input.ReadResHeader; 3081 LRSObjectBinaryToText(Input, Output); 3082end; 3083 3084procedure FormDataToText(FormStream, TextStream: TStream; aFormat: TLRSStreamOriginalFormat); 3085begin 3086 if aFormat = sofUnknown then 3087 aFormat := TestFormStreamFormat(FormStream); 3088 case aFormat of 3089 sofBinary: 3090 LRSObjectResourceToText(FormStream, TextStream); 3091 3092 sofText: 3093 begin 3094 if TextStream is TMemoryStream then 3095 TMemoryStream(TextStream).SetSize(TextStream.Position+FormStream.Size); 3096 TextStream.CopyFrom(FormStream,FormStream.Size); 3097 end; 3098 3099 else 3100 raise Exception.Create(rsInvalidFormObjectStream); 3101 end; 3102end; 3103 3104function InitLazResourceComponent(Instance: TComponent; 3105 RootAncestor: TClass): Boolean; 3106 3107 function InitComponent(ClassType: TClass): Boolean; 3108 var 3109 {$ifdef UseLRS} 3110 LazResource: TLResource; 3111 {$endif} 3112 {$ifdef UseRES} 3113 FPResource: TFPResourceHandle; 3114 {$endif} 3115 ResName: String; 3116 Stream: TStream; 3117 Reader: TReader; 3118 DestroyDriver: Boolean; 3119 Driver: TAbstractObjectReader; 3120 begin 3121 //DebugLn(['[InitComponent] ClassType=',ClassType.Classname,' Instance=',DbgsName(Instance),' RootAncestor=',DbgsName(RootAncestor),' ClassType.ClassParent=',DbgsName(ClassType.ClassParent)]); 3122 Result := False; 3123 if (ClassType = TComponent) or (ClassType = RootAncestor) then 3124 Exit; 3125 if Assigned(ClassType.ClassParent) then 3126 Result := InitComponent(ClassType.ClassParent); 3127 3128 Stream := nil; 3129 ResName := ClassType.ClassName; 3130 3131 {$ifdef UseLRS} 3132 LazResource := LazarusResources.Find(ResName); 3133 if (LazResource <> nil) and (LazResource.Value <> '') then 3134 Stream := TLazarusResourceStream.CreateFromHandle(LazResource); 3135 //DebugLn('[InitComponent] CompResource found for ',ClassType.Classname); 3136 {$endif} 3137 3138 {$ifdef UseRES} 3139 if Stream = nil then 3140 begin 3141 FPResource := FindResourceLFM(ResName); 3142 if FPResource <> 0 then 3143 Stream := TLazarusResourceStream.CreateFromHandle(HInstance, FPResource); 3144 end; 3145 {$endif} 3146 3147 if Stream = nil then 3148 Exit; 3149 3150 try 3151 //DebugLn('Form Stream "',ClassType.ClassName,'"'); 3152 //try 3153 DestroyDriver:=false; 3154 Reader := CreateLRSReader(Stream, DestroyDriver); 3155 try 3156 Reader.ReadRootComponent(Instance); 3157 finally 3158 Driver := Reader.Driver; 3159 Reader.Free; 3160 if DestroyDriver then 3161 Driver.Free; 3162 end; 3163 //except 3164 // on E: Exception do begin 3165 // DebugLn(Format(rsFormStreamingError,[ClassType.ClassName,E.Message])); 3166 // exit; 3167 // end; 3168 //end; 3169 finally 3170 Stream.Free; 3171 end; 3172 Result := True; 3173 end; 3174 3175begin 3176 if Instance.ComponentState * [csLoading, csInline] <> [] 3177 then begin 3178 // global loading not needed 3179 Result := InitComponent(Instance.ClassType); 3180 end 3181 else try 3182 BeginGlobalLoading; 3183 Result := InitComponent(Instance.ClassType); 3184 NotifyGlobalLoading; 3185 finally 3186 EndGlobalLoading; 3187 end; 3188end; 3189 3190function CreateLRSReader(s: TStream; var DestroyDriver: boolean): TReader; 3191var 3192 p: Pointer; 3193 Driver: TAbstractObjectReader; 3194begin 3195 Result:=TReader.Create(s,4096); 3196 //If included Default translator LRSTranslator will be set 3197 if Assigned(LRSTranslator) then 3198 Result.OnReadStringProperty:=@(LRSTranslator.TranslateStringProperty); 3199 3200 Result.OnPropertyNotFound := @(PropertiesToSkip.DoPropertyNotFound); 3201 3202 DestroyDriver:=false; 3203 if Result.Driver.ClassType=LRSObjectReaderClass then 3204 begin 3205 TLRSObjectReader(Result.Driver).Reader:=Result; 3206 exit; 3207 end; 3208 // hack to set a write protected variable. 3209 // DestroyDriver:=true; TReader will free it 3210 Driver:=LRSObjectReaderClass.Create(s,4096); 3211 p:=@Result.Driver; 3212 Result.Driver.Free; 3213 TAbstractObjectReader(p^):=Driver; 3214 TLRSObjectReader(Driver).Reader:=Result; 3215end; 3216 3217function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter; 3218var 3219 Driver: TAbstractObjectWriter; 3220begin 3221 Driver:=LRSObjectWriterClass.Create(s,4096); 3222 DestroyDriver:=true; 3223 Result:=TWriter.Create(Driver); 3224 TLRSObjectWriter(Driver).Writer:=Result; 3225end; 3226 3227{ LRS format converter functions } 3228 3229procedure ReverseBytes(p: Pointer; Count: integer); 3230var 3231 p1: PChar; 3232 p2: PChar; 3233 c: Char; 3234begin 3235 p1:=PChar(p); 3236 p2:=PChar(p)+Count-1; 3237 while p1<p2 do begin 3238 c:=p1^; 3239 p1^:=p2^; 3240 p2^:=c; 3241 inc(p1); 3242 dec(p2); 3243 end; 3244end; 3245 3246procedure ReverseByteOrderInWords(p: PWord; Count: integer); 3247var 3248 i: Integer; 3249 w: Word; 3250begin 3251 for i:=0 to Count-1 do begin 3252 w:=p[i]; 3253 w:=(w shr 8) or ((w and $ff) shl 8); 3254 p[i]:=w; 3255 end; 3256end; 3257 3258function ConvertLRSExtendedToDouble(p: Pointer): Double; 3259type 3260 Ti386ExtendedReversed = packed record 3261 {$IFDEF FPC_BIG_ENDIAN} 3262 ExponentAndSign: word; 3263 Mantissa: qword; 3264 {$ELSE} 3265 Mantissa: qword; 3266 ExponentAndSign: word; 3267 {$ENDIF} 3268 end; 3269var 3270 e: Ti386ExtendedReversed; 3271 Exponent: word; 3272 ExponentAndSign: word; 3273 Mantissa: qword; 3274begin 3275 System.Move(p^,e,10); 3276 {$IFDEF FPC_BIG_ENDIAN} 3277 ReverseBytes(@e,10); 3278 {$ENDIF} 3279 // i386 extended 3280 Exponent:=(e.ExponentAndSign and $7fff); 3281 if (Exponent>$4000+$3ff) or (Exponent<$4000-$400) then begin 3282 // exponent out of bounds 3283 Result:=0; 3284 exit; 3285 end; 3286 dec(Exponent,$4000-$400); 3287 ExponentAndSign:=Exponent or ((e.ExponentAndSign and $8000) shr 4); 3288 // i386 extended has leading 1, double has not (shl 1) 3289 // i386 has 64 bit, double has 52 bit (shr 12) 3290 {$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT} 3291 {$IFDEF FPC_BIG_ENDIAN} 3292 // accessing Mantissa will couse trouble, copy it first 3293 System.Move(e.Mantissa, Mantissa, SizeOf(Mantissa)); 3294 Mantissa := (Mantissa shl 1) shr 12; 3295 {$ELSE FPC_BIG_ENDIAN} 3296 Mantissa := (e.Mantissa shl 1) shr 12; 3297 {$ENDIF FPC_BIG_ENDIAN} 3298 {$ELSE FPC_REQUIRES_PROPER_ALIGNMENT} 3299 Mantissa := (e.Mantissa shl 1) shr 12; 3300 {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT} 3301 // put together 3302 QWord(Result):=Mantissa or (qword(ExponentAndSign) shl 52); 3303end; 3304 3305procedure ConvertEndianBigDoubleToLRSExtended(BigEndianDouble, 3306 LRSExtended: Pointer); 3307// Floats consists of a sign bit, some exponent bits and the mantissa bits 3308// A 0 is all bits 0 3309// not 0 has always a leading 1, which exponent is stored 3310// Single/Double does not save the leading 1, Extended does. 3311// 3312// Double is 8 bytes long, leftmost bit is sign, 3313// then 11 bit exponent based $400, then 52 bit mantissa without leading 1 3314// 3315// Extended is 10 bytes long, leftmost bit is sign, 3316// then 15 bit exponent based $4000, then 64 bit mantissa with leading 1 3317// EndianLittle means reversed byte order 3318var 3319 e: array[0..9] of byte; 3320 i: Integer; 3321 Exponent: Word; 3322 d: PByte; 3323begin 3324 d:=PByte(BigEndianDouble); 3325 // convert ppc double to i386 extended 3326 if (PCardinal(d)[0] or PCardinal(d)[1])=0 then begin 3327 // 0 3328 FillChar(LRSExtended^,10,#0); 3329 end else begin 3330 Exponent:=((d[0] and $7f) shl 4)+(d[1] shr 4); 3331 inc(Exponent,$4000-$400); 3332 if (d[0] and $80)>0 then 3333 // signed 3334 inc(Exponent,$8000); 3335 e[9]:=Exponent shr 8; 3336 e[8]:=Exponent and $ff; 3337 e[7]:=($80 or (d[1] shl 3) or (d[2] shr 5)) and $ff; 3338 for i:=3 to 7 do begin 3339 e[9-i]:=((d[i-1] shl 3) or (d[i] shr 5)) and $ff; 3340 end; 3341 e[1]:=(d[7] shl 3) and $ff; 3342 e[0]:=0; 3343 System.Move(e[0],LRSExtended^,10); 3344 end; 3345end; 3346 3347procedure ConvertLEDoubleToLRSExtended(LEDouble, LRSExtended: Pointer); 3348type 3349 TMantissaWrap = record 3350 case boolean of 3351 True: (Q: QWord); 3352 False: (B: array[0..7] of Byte); 3353 end; 3354 3355 TExpWrap = packed record 3356 Mantissa: TMantissaWrap; 3357 Exp: Word; 3358 end; 3359 3360var 3361 Q: PQWord absolute LEDouble; 3362 C: PCardinal absolute LEDouble; 3363 W: PWord absolute LEDouble; 3364 E: ^TExpWrap absolute LRSExtended; 3365 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} 3366 Mantissa: TMantissaWrap; 3367 {$endif} 3368begin 3369 if W[3] and $7FF0 = $7FF0 // infinite or NaN 3370 then E^.Exp := $7FFF 3371 else E^.Exp := (W[3] and $7FFF) shr 4 - $3FF + $3FFF; 3372 E^.Exp := E^.Exp or (W[3] and $8000); // sign 3373 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} 3374 Mantissa.Q := (Q^ shl 11); 3375 Mantissa.B[7] := Mantissa.B[7] or $80; // add ignored 1 3376 System.Move(Mantissa, E^.Mantissa, 8); 3377 {$else} 3378 E^.Mantissa.Q := (Q^ shl 11); 3379 E^.Mantissa.B[7] := E^.Mantissa.B[7] or $80; // add ignored 1 3380 {$endif} 3381end; 3382 3383function ReadLRSShortInt(s: TStream): shortint; 3384begin 3385 Result:=0; 3386 s.Read(Result,1); 3387end; 3388 3389function ReadLRSByte(s: TStream): byte; 3390begin 3391 Result:=0; 3392 s.Read(Result,1); 3393end; 3394 3395function ReadLRSWord(s: TStream): word; 3396begin 3397 Result:=0; 3398 s.Read(Result,2); 3399 {$IFDEF FPC_BIG_ENDIAN} 3400 Result:=((Result and $ff) shl 8) or (Result shr 8); 3401 {$ENDIF} 3402end; 3403 3404function ReadLRSSmallInt(s: TStream): smallint; 3405begin 3406 Result:=0; 3407 {$IFDEF FPC_BIG_ENDIAN} 3408 Result:=smallint(ReadLRSWord(s)); 3409 {$ELSE} 3410 s.Read(Result,2); 3411 {$ENDIF} 3412end; 3413 3414function ReadLRSInteger(s: TStream): integer; 3415begin 3416 Result:=0; 3417 s.Read(Result,4); 3418 {$IFDEF FPC_BIG_ENDIAN} 3419 ReverseBytes(@Result,4); 3420 {$ENDIF} 3421end; 3422 3423function ReadLRSCardinal(s: TStream): cardinal; 3424begin 3425 Result:=0; 3426 s.Read(Result,4); 3427 {$IFDEF FPC_BIG_ENDIAN} 3428 ReverseBytes(@Result,4); 3429 {$ENDIF} 3430end; 3431 3432function ReadLRSInt64(s: TStream): int64; 3433begin 3434 Result:=0; 3435 s.Read(Result,8); 3436 {$IFDEF FPC_BIG_ENDIAN} 3437 ReverseBytes(@Result,8); 3438 {$ENDIF} 3439end; 3440 3441function ReadLRSSingle(s: TStream): Single; 3442begin 3443 Result:=0; 3444 s.Read(Result,4); 3445 {$IFDEF FPC_BIG_ENDIAN} 3446 ReverseBytes(@Result,4); 3447 {$ENDIF} 3448end; 3449 3450function ReadLRSDouble(s: TStream): Double; 3451begin 3452 Result:=0; 3453 s.Read(Result,8); 3454 {$IFDEF FPC_BIG_ENDIAN} 3455 ReverseBytes(@Result,8); 3456 {$ENDIF} 3457end; 3458 3459function ReadLRSExtended(s: TStream): Extended; 3460begin 3461 Result:=0; 3462 {$IFDEF FPC_HAS_TYPE_EXTENDED} 3463 s.Read(Result,10); 3464 {$IFDEF FPC_BIG_ENDIAN} 3465 ReverseBytes(@Result,10); 3466 {$ENDIF} 3467 {$ELSE} 3468 // possible endian conversion is handled in ConvertLRSExtendedToDouble 3469 Result:=ReadLRSEndianLittleExtendedAsDouble(s); 3470 {$ENDIF} 3471end; 3472 3473function ReadLRSCurrency(s: TStream): Currency; 3474begin 3475 Result:=0; 3476 s.Read(Result,8); 3477 {$IFDEF FPC_BIG_ENDIAN} 3478 ReverseBytes(@Result,8); 3479 {$ENDIF} 3480end; 3481 3482function ReadLRSWideString(s: TStream): WideString; 3483var 3484 Len: LongInt; 3485begin 3486 Len:=ReadLRSInteger(s); 3487 SetLength(Result,Len); 3488 if Len>0 then begin 3489 s.Read(Result[1],Len*2); 3490 {$IFDEF FPC_BIG_ENDIAN} 3491 ReverseByteOrderInWords(PWord(@Result[1]),Len); 3492 {$ENDIF} 3493 end; 3494end; 3495 3496function ReadLRSEndianLittleExtendedAsDouble(s: TStream): Double; 3497var 3498 e: array[1..10] of byte; 3499begin 3500 s.Read(e,10); 3501 Result:=ConvertLRSExtendedToDouble(@e); 3502end; 3503 3504function ReadLRSValueType(s: TStream): TValueType; 3505var 3506 b: byte; 3507begin 3508 s.Read(b,1); 3509 Result:=TValueType(b); 3510end; 3511 3512function ReadLRSInt64MB(s: TStream): int64; 3513var 3514 v: TValueType; 3515begin 3516 v:=ReadLRSValueType(s); 3517 case v of 3518 vaInt8: Result:=ReadLRSShortInt(s); 3519 vaInt16: Result:=ReadLRSSmallInt(s); 3520 vaInt32: Result:=ReadLRSInteger(s); 3521 vaInt64: Result:=ReadLRSInt64(s); 3522 else 3523 raise EInOutError.Create('ordinal valuetype missing'); 3524 end; 3525end; 3526 3527procedure WriteLRSReversedWord(s: TStream; w: word); 3528begin 3529 w:=(w shr 8) or ((w and $ff) shl 8); 3530 s.Write(w,2); 3531end; 3532 3533procedure WriteLRS4BytesReversed(s: TStream; p: Pointer); 3534var 3535 a: array[0..3] of char; 3536 i: Integer; 3537begin 3538 for i:=0 to 3 do 3539 a[i]:=PChar(p)[3-i]; 3540 s.Write(a[0],4); 3541end; 3542 3543procedure WriteLRS8BytesReversed(s: TStream; p: Pointer); 3544var 3545 a: array[0..7] of char; 3546 i: Integer; 3547begin 3548 for i:=0 to 7 do 3549 a[i]:=PChar(p)[7-i]; 3550 s.Write(a[0],8); 3551end; 3552 3553procedure WriteLRS10BytesReversed(s: TStream; p: Pointer); 3554var 3555 a: array[0..9] of char; 3556 i: Integer; 3557begin 3558 for i:=0 to 9 do 3559 a[i]:=PChar(p)[9-i]; 3560 s.Write(a[0],10); 3561end; 3562 3563procedure WriteLRSReversedWords(s: TStream; p: Pointer; Count: integer); 3564var 3565 w: Word; 3566 i: Integer; 3567begin 3568 for i:=0 to Count-1 do begin 3569 w:=PWord(P)[i]; 3570 w:=(w shr 8) or ((w and $ff) shl 8); 3571 s.Write(w,2); 3572 end; 3573end; 3574 3575function FloatToLFMStr(const Value: extended; Precision, Digits: Integer): string; 3576var 3577 P: Integer; 3578 TooSmall, TooLarge: Boolean; 3579 DeletePos: LongInt; 3580begin 3581 Result:=''; 3582 If (Precision = -1) or (Precision > 15) then Precision := 15; 3583 3584 TooSmall := (Abs(Value) < 0.00001) and (Value>0.0); 3585 if TooSmall then begin 3586 P := 0; 3587 TooLarge := False; 3588 end 3589 else begin 3590 Str(Value:digits:precision, Result); 3591 P := Pos('.', Result); 3592 TooLarge :=(P > Precision + 1) or (Pos('E', Result)<>0); 3593 End; 3594 3595 if TooSmall or TooLarge then begin 3596 // use exponential format 3597 Str(Value:Precision + 8, Result); 3598 P:=4; 3599 while (P>0) and (Digits < P) and (Result[Precision + 5] = '0') do begin 3600 if P<>1 then 3601 system.Delete(Result, Precision + 5, 1) 3602 else 3603 system.Delete(Result, Precision + 3, 3); 3604 Dec(P); 3605 end; 3606 if Result[1] = ' ' then 3607 System.Delete(Result, 1, 1); 3608 // Strip unneeded zeroes. 3609 P:=Pos('E',result)-1; 3610 If P>=0 then begin 3611 { delete superfluous +? } 3612 if result[p+2]='+' then 3613 system.Delete(Result,P+2,1); 3614 DeletePos:=p; 3615 while (DeletePos>1) and (Result[DeletePos]='0') do 3616 Dec(DeletePos); 3617 if (DeletePos>0) and (Result[DeletePos]=DefaultFormatSettings.DecimalSeparator) Then 3618 Dec(DeletePos); 3619 if (DeletePos<p) then 3620 system.Delete(Result,DeletePos,p-DeletePos); 3621 end; 3622 end 3623 else if (P<>0) then begin 3624 // we have a decimalseparator 3625 P := Length(Result); 3626 While (P>0) and (Result[P] = '0') Do 3627 Dec(P); 3628 If (P>0) and (Result[P]=DefaultFormatSettings.DecimalSeparator) Then 3629 Dec(P); 3630 SetLength(Result, P); 3631 end; 3632end; 3633 3634function CompareLRPositionLinkWithLFMPosition(Item1, Item2: Pointer): integer; 3635var 3636 p1: Int64; 3637 p2: Int64; 3638begin 3639 p1:=PLRPositionLink(Item1)^.LFMPosition; 3640 p2:=PLRPositionLink(Item2)^.LFMPosition; 3641 if p1<p2 then 3642 Result:=1 3643 else if p1>p2 then 3644 Result:=-1 3645 else 3646 Result:=0; 3647end; 3648 3649function CompareLRPositionLinkWithLRSPosition(Item1, Item2: Pointer): integer; 3650var 3651 p1: Int64; 3652 p2: Int64; 3653begin 3654 p1:=PLRPositionLink(Item1)^.LRSPosition; 3655 p2:=PLRPositionLink(Item2)^.LRSPosition; 3656 if p1<p2 then 3657 Result:=1 3658 else if p1>p2 then 3659 Result:=-1 3660 else 3661 Result:=0; 3662end; 3663 3664procedure RegisterPropertyToSkip(PersistentClass: TPersistentClass; 3665 const PropertyName, Note, HelpKeyWord: string); 3666begin 3667 PropertiesToSkip.Add(PersistentClass, PropertyName, Note, HelpKeyWord); 3668end; 3669 3670procedure Register; 3671begin 3672 RegisterComponents('System',[TLazComponentQueue]); 3673end; 3674 3675procedure WriteLRSNull(s: TStream; Count: integer); 3676var 3677 c: char; 3678 i: Integer; 3679begin 3680 c:=#0; 3681 for i:=0 to Count-1 do 3682 s.Write(c,1); 3683end; 3684 3685procedure WriteLRSEndianBigDoubleAsEndianLittleExtended(s: TStream; 3686 EndBigDouble: PByte); 3687var 3688 e: array[0..9] of byte; 3689begin 3690 ConvertEndianBigDoubleToLRSExtended(EndBigDouble,@e); 3691 s.Write(e[0],10); 3692end; 3693 3694procedure WriteLRSDoubleAsExtended(s: TStream; ADouble: PByte); 3695var 3696 e: array[0..9] of byte; 3697begin 3698 {$ifdef FPC_LITTLE_ENDIAN} 3699 ConvertLEDoubleToLRSExtended(ADouble,@e); 3700 {$else} 3701 ConvertEndianBigDoubleToLRSExtended(ADouble,@e); 3702 {$endif} 3703 s.Write(e[0],10); 3704end; 3705 3706 3707procedure WriteLRSSmallInt(s: TStream; const i: SmallInt); 3708begin 3709 {$IFDEF FPC_LITTLE_ENDIAN} 3710 s.Write(i,2); 3711 {$ELSE} 3712 WriteLRSReversedWord(s,Word(i)); 3713 {$ENDIF} 3714end; 3715 3716procedure WriteLRSWord(s: TStream; const w: word); 3717begin 3718 {$IFDEF FPC_LITTLE_ENDIAN} 3719 s.Write(w,2); 3720 {$ELSE} 3721 WriteLRSReversedWord(s,w); 3722 {$ENDIF} 3723end; 3724 3725procedure WriteLRSInteger(s: TStream; const i: integer); 3726begin 3727 {$IFDEF FPC_LITTLE_ENDIAN} 3728 s.Write(i,4); 3729 {$ELSE} 3730 WriteLRS4BytesReversed(s,@i); 3731 {$ENDIF} 3732end; 3733 3734procedure WriteLRSCardinal(s: TStream; const c: cardinal); 3735begin 3736 {$IFDEF FPC_LITTLE_ENDIAN} 3737 s.Write(c,4); 3738 {$ELSE} 3739 WriteLRS4BytesReversed(s,@c); 3740 {$ENDIF} 3741end; 3742 3743procedure WriteLRSSingle(s: TStream; const si: Single); 3744begin 3745 {$IFDEF FPC_LITTLE_ENDIAN} 3746 s.Write(si,4); 3747 {$ELSE} 3748 WriteLRS4BytesReversed(s,@si); 3749 {$ENDIF} 3750end; 3751 3752procedure WriteLRSDouble(s: TStream; const d: Double); 3753begin 3754 {$IFDEF FPC_LITTLE_ENDIAN} 3755 s.Write(d,8); 3756 {$ELSE} 3757 WriteLRS8BytesReversed(s,@d); 3758 {$ENDIF} 3759end; 3760 3761procedure WriteLRSExtended(s: TStream; const e: extended); 3762begin 3763 {$IFDEF FPC_HAS_TYPE_EXTENDED} 3764 {$IFDEF FPC_BIG_ENDIAN} 3765 WriteLRS10BytesReversed(s, @e); 3766 {$ELSE} 3767 s.Write(e,10); 3768 {$ENDIF} 3769 {$ELSE} 3770 WriteLRSDoubleAsExtended(s,pbyte(@e)) 3771 {$ENDIF} 3772end; 3773 3774procedure WriteLRSInt64(s: TStream; const i: int64); 3775begin 3776 {$IFDEF FPC_LITTLE_ENDIAN} 3777 s.Write(i,8); 3778 {$ELSE} 3779 WriteLRS8BytesReversed(s,@i); 3780 {$ENDIF} 3781end; 3782 3783procedure WriteLRSCurrency(s: TStream; const c: Currency); 3784begin 3785 {$IFDEF FPC_LITTLE_ENDIAN} 3786 s.Write(c,8); 3787 {$ELSE} 3788 WriteLRS8BytesReversed(s,@c); 3789 {$ENDIF} 3790end; 3791 3792procedure WriteLRSWideStringContent(s: TStream; const w: WideString); 3793var 3794 Size: Integer; 3795begin 3796 Size:=length(w); 3797 if Size=0 then exit; 3798 {$IFDEF FPC_LITTLE_ENDIAN} 3799 s.Write(w[1], Size * 2); 3800 {$ELSE} 3801 WriteLRSReversedWords(s,@w[1],Size); 3802 {$ENDIF} 3803end; 3804 3805procedure WriteLRSInt64MB(s: TStream; const Value: int64); 3806var 3807 w: Word; 3808 i: Integer; 3809 b: Byte; 3810begin 3811 // Use the smallest possible integer type for the given value: 3812 if (Value >= -128) and (Value <= 127) then 3813 begin 3814 b:=byte(vaInt8); 3815 s.Write(b, 1); 3816 b:=byte(Value); 3817 s.Write(b, 1); 3818 end else if (Value >= -32768) and (Value <= 32767) then 3819 begin 3820 b:=byte(vaInt16); 3821 s.Write(b, 1); 3822 w:=Word(Value); 3823 WriteLRSWord(s,w); 3824 end else if (Value >= -$80000000) and (Value <= $7fffffff) then 3825 begin 3826 b:=byte(vaInt32); 3827 s.Write(b, 1); 3828 i:=Integer(Value); 3829 WriteLRSInteger(s,i); 3830 end else 3831 begin 3832 b:=byte(vaInt64); 3833 s.Write(b, 1); 3834 WriteLRSInt64(s,Value); 3835 end; 3836end; 3837 3838{ TLRSObjectReader } 3839 3840procedure TLRSObjectReader.Read(var Buf; Count: LongInt); 3841var 3842 CopyNow: LongInt; 3843 Dest: Pointer; 3844begin 3845 Dest := @Buf; 3846 while Count > 0 do 3847 begin 3848 if FBufPos >= FBufEnd then 3849 begin 3850 FBufEnd := FStream.Read(FBuffer^, FBufSize); 3851 if FBufEnd = 0 then 3852 raise EReadError.Create('Read Error'); 3853 FBufPos := 0; 3854 end; 3855 CopyNow := FBufEnd - FBufPos; 3856 if CopyNow > Count then 3857 CopyNow := Count; 3858 Move(PChar(FBuffer)[FBufPos], Dest^, CopyNow); 3859 Inc(FBufPos, CopyNow); 3860 Dest:=Dest+CopyNow; 3861 Dec(Count, CopyNow); 3862 end; 3863end; 3864 3865procedure TLRSObjectReader.SkipProperty; 3866begin 3867 { Skip property name, then the property value } 3868 ReadStr; 3869 SkipValue; 3870end; 3871 3872procedure TLRSObjectReader.SkipSetBody; 3873begin 3874 while Length(ReadStr) > 0 do; 3875end; 3876 3877procedure TLRSObjectReader.Push(ItemType: TLRSItemType; const AName: string; 3878 Root: TComponent; PushCount: integer); 3879begin 3880 if FStackPointer=FStackCapacity then begin 3881 FStackCapacity:=FStackCapacity*2+10; 3882 ReAllocMem(FStack,SizeOf(TLRSORStackItem)*FStackCapacity); 3883 FillByte(FStack[FStackPointer],SizeOf(TLRSORStackItem)*(FStackCapacity-FStackPointer),0); 3884 end; 3885 //DebugLn(['TLRSObjectReader.Push AName=',AName,' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount]); 3886 FStack[FStackPointer].Name:=AName; 3887 FStack[FStackPointer].ItemType:=ItemType; 3888 FStack[FStackPointer].Root:=Root; 3889 FStack[FStackPointer].PushCount:=PushCount; 3890 FStack[FStackPointer].ItemNr:=-1; 3891 inc(FStackPointer); 3892end; 3893 3894procedure TLRSObjectReader.Pop; 3895var 3896 Item: PLRSORStackItem; 3897begin 3898 if FStackPointer=0 then 3899 raise Exception.Create('Error: TLRSObjectReader.Pop stack is empty'); 3900 Item:=@FStack[FStackPointer-1]; 3901 //DebugLn(['TLRSObjectReader.Pop AName=',Item^.Name, 3902 // ' Type=',GetEnumName(TypeInfo(TLRSItemType), Integer(item^.ItemType)), 3903 // ' PushCount=',item^.PushCount,' StackPtr=', FStackPointer]); 3904 if Item^.PushCount>1 then begin 3905 // stack item still needs more EndList 3906 dec(Item^.PushCount); 3907 end else begin 3908 // stack item is complete 3909 dec(FStackPointer); 3910 end; 3911end; 3912 3913procedure TLRSObjectReader.ClearStack; 3914var 3915 i: Integer; 3916begin 3917 for i:=0 to FStackCapacity-1 do begin 3918 FStack[i].Name:=''; 3919 end; 3920 ReAllocMem(FStack,0); 3921end; 3922 3923function TLRSObjectReader.InternalReadValue: TValueType; 3924var 3925 b: byte; 3926begin 3927 Result := vaNull; { Necessary in FPC as TValueType is larger than 1 byte! } 3928 Read(b,1); 3929 Result:=TValueType(b); 3930end; 3931 3932function TLRSObjectReader.ReadIntegerContent: integer; 3933begin 3934 Result:=0; 3935 Read(Result,4); 3936 {$ifdef FPC_BIG_ENDIAN} 3937 ReverseBytes(@Result,4); 3938 {$endif} 3939end; 3940 3941constructor TLRSObjectReader.Create(AStream: TStream; BufSize: Integer); 3942begin 3943 inherited Create; 3944 FStream := AStream; 3945 FBufSize := BufSize; 3946 GetMem(FBuffer, BufSize); 3947end; 3948 3949destructor TLRSObjectReader.Destroy; 3950begin 3951 { Seek back the amount of bytes that we didn't process until now: } 3952 if Assigned(FStream) then 3953 FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), soFromCurrent); 3954 3955 if Assigned(FBuffer) then 3956 FreeMem(FBuffer, FBufSize); 3957 3958 ClearStack; 3959 3960 inherited Destroy; 3961end; 3962 3963function TLRSObjectReader.ReadValue: TValueType; 3964begin 3965 Result := InternalReadValue; 3966 case Result of 3967 vaNull: 3968 begin 3969 EndPropertyIfOpen; 3970 // End previous element collection, list or component. 3971 if FStackPointer > 0 then 3972 Pop; 3973 end; 3974 vaCollection: 3975 begin 3976 Push(lrsitCollection); 3977 end; 3978 vaList: 3979 begin 3980 // Increase counter for next collection item. 3981 if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then 3982 Inc(FStack[FStackPointer-1].ItemNr); 3983 Push(lrsitList); 3984 end; 3985 end; 3986end; 3987 3988function TLRSObjectReader.NextValue: TValueType; 3989begin 3990 Result := InternalReadValue; 3991 { We only 'peek' at the next value, so seek back to unget the read value: } 3992 Dec(FBufPos); 3993end; 3994 3995procedure TLRSObjectReader.BeginRootComponent; 3996var 3997 Signature: TFilerSignature; 3998begin 3999 { Read filer signature } 4000 Signature:='1234'; 4001 Read(Signature[1],length(Signature)); 4002 if Signature <> FilerSignature then 4003 raise EReadError.Create('Invalid Filer Signature'); 4004end; 4005 4006procedure TLRSObjectReader.BeginComponent(var Flags: TFilerFlags; 4007 var AChildPos: Integer; var CompClassName, CompName: String); 4008var 4009 Prefix: Byte; 4010 ValueType: TValueType; 4011 ItemName: String; 4012 ItemRoot: TComponent; 4013begin 4014 { Every component can start with a special prefix: } 4015 Flags := []; 4016 if (Byte(NextValue) and $f0) = $f0 then 4017 begin 4018 Prefix := Byte(ReadValue); 4019 if (ObjStreamMaskInherited and Prefix)<>0 then 4020 Include(Flags,ffInherited); 4021 if (ObjStreamMaskInline and Prefix)<>0 then 4022 Include(Flags,ffInline); 4023 if (ObjStreamMaskChildPos and Prefix)<>0 then 4024 begin 4025 Include(Flags,ffChildPos); 4026 ValueType := ReadValue; 4027 case ValueType of 4028 vaInt8: 4029 AChildPos := ReadInt8; 4030 vaInt16: 4031 AChildPos := ReadInt16; 4032 vaInt32: 4033 AChildPos := ReadInt32; 4034 else 4035 PropValueError; 4036 end; 4037 end; 4038 end; 4039 4040 CompClassName := ReadStr; 4041 CompName := ReadStr; 4042 4043 // Top component is addressed by ClassName. 4044 if FStackPointer = 0 then 4045 begin 4046 ItemName := CompClassName; 4047 ItemRoot := nil; 4048 end 4049 else 4050 begin 4051 ItemName := CompName; 4052 if Assigned(Reader) then 4053 // Reader.LookupRoot is the current Root component. 4054 ItemRoot := Reader.LookupRoot 4055 else 4056 ItemRoot := nil; 4057 end; 4058 4059 // A component has two lists: properties and childs, hence PopCount=2. 4060 Push(lrsitComponent, ItemName, ItemRoot, 2); 4061end; 4062 4063function TLRSObjectReader.BeginProperty: String; 4064begin 4065 EndPropertyIfOpen; 4066 Result := ReadStr; 4067 Push(lrsitProperty, Result); 4068end; 4069 4070procedure TLRSObjectReader.EndPropertyIfOpen; 4071begin 4072 // End previous property. 4073 if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitProperty) then 4074 Pop; 4075end; 4076 4077function TLRSObjectReader.GetStackPath: string; 4078var 4079 i: Integer; 4080 CurName: string; 4081 Item: PLRSORStackItem; 4082begin 4083 Result:=''; 4084 4085 for i:=0 to FStackPointer-1 do 4086 begin 4087 Item := @FStack[i]; 4088 4089 // Reader.Root is the top component in the module. 4090 if Assigned(Reader) and 4091 (Item^.ItemType = lrsitComponent) and 4092 (Item^.Root = Reader.Root) and 4093 (Item^.Root <> nil) then 4094 begin 4095 // Restart path from top component. 4096 Result := Item^.Root.ClassName; 4097 end; 4098 4099 CurName:=Item^.Name; 4100 if CurName<>'' then begin 4101 if Result<>'' then Result:=Result+'.'; 4102 Result:=Result+CurName; 4103 end; 4104 if Item^.ItemNr >= 0 then 4105 Result := Result + '[' + IntToStr(Item^.ItemNr) + ']'; 4106 end; 4107end; 4108 4109procedure TLRSObjectReader.ReadBinary(const DestData: TMemoryStream); 4110var 4111 BinSize: LongInt; 4112begin 4113 BinSize:=ReadIntegerContent; 4114 DestData.Size := BinSize; 4115 Read(DestData.Memory^, BinSize); 4116end; 4117 4118function TLRSObjectReader.ReadFloat: Extended; 4119{$ifndef FPC_HAS_TYPE_EXTENDED} 4120var 4121 e: array[1..10] of byte; 4122{$endif} 4123begin 4124 Result:=0; 4125 {$ifdef FPC_HAS_TYPE_EXTENDED} 4126 Read(Result, 10); 4127 {$ifdef FPC_BIG_ENDIAN} 4128 ReverseBytes(@Result, 10); 4129 {$endif FPC_BIG_ENDIAN} 4130 {$else FPC_HAS_TYPE_EXTENDED} 4131 Read(e, 10); 4132 Result := ConvertLRSExtendedToDouble(@e); 4133 {$endif FPC_HAS_TYPE_EXTENDED} 4134end; 4135 4136function TLRSObjectReader.ReadSingle: Single; 4137begin 4138 Result:=0; 4139 Read(Result, 4); 4140 {$ifdef FPC_BIG_ENDIAN} 4141 ReverseBytes(@Result,4); 4142 {$endif} 4143end; 4144 4145function TLRSObjectReader.ReadCurrency: Currency; 4146begin 4147 Result:=0; 4148 Read(Result, 8); 4149 {$ifdef FPC_BIG_ENDIAN} 4150 ReverseBytes(@Result,8); 4151 {$endif} 4152end; 4153 4154function TLRSObjectReader.ReadDate: TDateTime; 4155begin 4156 Result:=0; 4157 Read(Result, 8); 4158 {$ifdef FPC_BIG_ENDIAN} 4159 ReverseBytes(@Result,8); 4160 {$endif} 4161end; 4162 4163function TLRSObjectReader.ReadIdent(ValueType: TValueType): String; 4164var 4165 b: Byte; 4166begin 4167 case ValueType of 4168 vaIdent: 4169 begin 4170 Read(b, 1); 4171 SetLength(Result, b); 4172 if ( b > 0 ) then 4173 Read(Result[1], b); 4174 end; 4175 vaNil: 4176 Result := 'nil'; 4177 vaFalse: 4178 Result := 'False'; 4179 vaTrue: 4180 Result := 'True'; 4181 vaNull: 4182 Result := 'Null'; 4183 else 4184 Result:=''; 4185 RaiseGDBException(''); 4186 end; 4187end; 4188 4189function TLRSObjectReader.ReadInt8: ShortInt; 4190begin 4191 Result:=0; 4192 Read(Result, 1); 4193end; 4194 4195function TLRSObjectReader.ReadInt16: SmallInt; 4196begin 4197 Result:=0; 4198 Read(Result, 2); 4199 {$ifdef FPC_BIG_ENDIAN} 4200 ReverseBytes(@Result,2); 4201 {$endif} 4202end; 4203 4204function TLRSObjectReader.ReadInt32: LongInt; 4205begin 4206 Result:=0; 4207 Read(Result, 4); 4208 {$ifdef FPC_BIG_ENDIAN} 4209 ReverseBytes(@Result,4); 4210 {$endif} 4211end; 4212 4213function TLRSObjectReader.ReadInt64: Int64; 4214begin 4215 Result:=0; 4216 Read(Result, 8); 4217 {$ifdef FPC_BIG_ENDIAN} 4218 ReverseBytes(@Result,8); 4219 {$endif} 4220end; 4221 4222function TLRSObjectReader.ReadSet(EnumType: Pointer): Integer; 4223type 4224 tset = set of 0..31; 4225var 4226 OName: String; 4227 OValue: Integer; 4228begin 4229 try 4230 Result := 0; 4231 while True do 4232 begin 4233 OName := ReadStr; 4234 if Length(OName) = 0 then 4235 break; 4236 OValue := GetEnumValue(PTypeInfo(EnumType), OName); 4237 // Eg. "Options" is a set and can give an error when changing component type. 4238 // Do nothing on error (OValue = -1), was PropValueError; (JuMa) 4239 if OValue >= 0 then 4240 include(tset(result),OValue); 4241 end; 4242 except 4243 SkipSetBody; 4244 raise; 4245 end; 4246end; 4247 4248{$IF FPC_FULLVERSION >= 30000} 4249procedure TLRSObjectReader.ReadSignature; 4250begin 4251end; 4252{$ENDIF} 4253 4254function TLRSObjectReader.ReadStr: String; 4255var 4256 b: Byte; 4257begin 4258 Read(b, 1); 4259 SetLength(Result, b); 4260 if b > 0 then 4261 Read(Result[1], b); 4262end; 4263 4264function TLRSObjectReader.ReadString(StringType: TValueType): String; 4265var 4266 i: Integer; 4267 b: byte; 4268begin 4269 case StringType of 4270 vaString: 4271 begin 4272 Read(b, 1); 4273 i:=b; 4274 end; 4275 vaLString: 4276 i:=ReadIntegerContent; 4277 else 4278 raise Exception.Create('TLRSObjectReader.ReadString invalid StringType'); 4279 end; 4280 SetLength(Result, i); 4281 if i > 0 then 4282 Read(Pointer(@Result[1])^, i); 4283end; 4284 4285function TLRSObjectReader.ReadWideString: WideString; 4286var 4287 i: Integer; 4288begin 4289 i:=ReadIntegerContent; 4290 SetLength(Result, i); 4291 if i > 0 then 4292 Read(Pointer(@Result[1])^, i*2); 4293 //debugln('TLRSObjectReader.ReadWideString ',Result); 4294end; 4295 4296function TLRSObjectReader.ReadUnicodeString: UnicodeString; 4297var 4298 i: Integer; 4299begin 4300 i:=ReadIntegerContent; 4301 SetLength(Result, i); 4302 if i > 0 then 4303 Read(Pointer(@Result[1])^, i*2); 4304 //debugln('TLRSObjectReader.ReadWideString ',Result); 4305end; 4306 4307procedure TLRSObjectReader.SkipComponent(SkipComponentInfos: Boolean); 4308var 4309 Flags: TFilerFlags; 4310 Dummy: Integer; 4311 CompClassName, CompName: String; 4312begin 4313 if SkipComponentInfos then 4314 { Skip prefix, component class name and component object name } 4315 BeginComponent(Flags, Dummy, CompClassName, CompName); 4316 4317 { Skip properties } 4318 while NextValue <> vaNull do 4319 SkipProperty; 4320 ReadValue; 4321 4322 { Skip children } 4323 while NextValue <> vaNull do 4324 SkipComponent(True); 4325 ReadValue; 4326end; 4327 4328procedure TLRSObjectReader.SkipValue; 4329 4330 procedure SkipBytes(Count: LongInt); 4331 var 4332 Dummy: array[0..1023] of Byte; 4333 SkipNow: Integer; 4334 begin 4335 while Count > 0 do 4336 begin 4337 if Count > 1024 then 4338 SkipNow := 1024 4339 else 4340 SkipNow := Count; 4341 Read(Dummy, SkipNow); 4342 Dec(Count, SkipNow); 4343 end; 4344 end; 4345 4346var 4347 Count: LongInt; 4348begin 4349 case ReadValue of 4350 vaNull, vaFalse, vaTrue, vaNil: ; 4351 vaList: 4352 begin 4353 while NextValue <> vaNull do 4354 SkipValue; 4355 ReadValue; 4356 end; 4357 vaInt8: 4358 SkipBytes(1); 4359 vaInt16: 4360 SkipBytes(2); 4361 vaInt32: 4362 SkipBytes(4); 4363 vaExtended: 4364 SkipBytes(10); 4365 vaString, vaIdent: 4366 ReadStr; 4367 vaBinary, vaLString: 4368 begin 4369 Count:=ReadIntegerContent; 4370 SkipBytes(Count); 4371 end; 4372 vaWString, vaUString: 4373 begin 4374 Count:=ReadIntegerContent; 4375 SkipBytes(Count*2); 4376 end; 4377 vaSet: 4378 SkipSetBody; 4379 vaCollection: 4380 begin 4381 while NextValue <> vaNull do 4382 begin 4383 { Skip the order value if present } 4384 if NextValue in [vaInt8, vaInt16, vaInt32] then 4385 SkipValue; 4386 SkipBytes(1); 4387 while NextValue <> vaNull do 4388 SkipProperty; 4389 ReadValue; 4390 end; 4391 ReadValue; 4392 end; 4393 vaSingle: 4394 SkipBytes(4); 4395 vaCurrency: 4396 SkipBytes(SizeOf(Currency)); 4397 vaDate: 4398 SkipBytes(8); 4399 vaInt64: 4400 SkipBytes(8); 4401 else 4402 RaiseGDBException('TLRSObjectReader.SkipValue unknown valuetype'); 4403 end; 4404end; 4405 4406{ TLRSObjectWriter } 4407 4408procedure TLRSObjectWriter.Push(ItemType: TLRSItemType; const AName: string; 4409 Root: TComponent; PushCount: integer; 4410 SkipIfEmpty: boolean); 4411begin 4412 if FStackPointer=FStackCapacity then begin 4413 FStackCapacity:=FStackCapacity*2+10; 4414 ReAllocMem(FStack,SizeOf(TLRSOWStackItem)*FStackCapacity); 4415 FillByte(FStack[FStackPointer],SizeOf(TLRSOWStackItem)*(FStackCapacity-FStackPointer),0); 4416 end; 4417 //if AName<>'' then DebugLn(['TLRSObjectWriter.Push AName=',AName, ' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount,' SkipIfEmpty=',SkipIfEmpty]); 4418 FStack[FStackPointer].Name:=AName; 4419 FStack[FStackPointer].ItemType:=ItemType; 4420 FStack[FStackPointer].Root:=Root; 4421 FStack[FStackPointer].PushCount:=PushCount; 4422 FStack[FStackPointer].ItemNr:=-1; 4423 FStack[FStackPointer].SkipIfEmpty:=SkipIfEmpty; 4424 FStack[FStackPointer].BufCount:=0; 4425 if SkipIfEmpty then 4426 FStack[FStackPointer].State:=lrsowsisStarted 4427 else begin 4428 FlushStackToStream; 4429 FStack[FStackPointer].State:=lrsowsisDataWritten; 4430 end; 4431 inc(FStackPointer); 4432end; 4433 4434procedure TLRSObjectWriter.EndHeader; 4435var 4436 Item: PLRSOWStackItem; 4437begin 4438 Item:=@FStack[FStackPointer-1]; 4439 if Item^.State=lrsowsisStarted then 4440 Item^.State:=lrsowsisHeaderWritten; 4441end; 4442 4443procedure TLRSObjectWriter.Pop(WriteNull: boolean); 4444var 4445 Item: PLRSOWStackItem; 4446begin 4447 if FStackPointer=0 then 4448 raise Exception.Create('Error: TLRSObjectWriter.Pop stack is empty'); 4449 Item:=@FStack[FStackPointer-1]; 4450 if Item^.PushCount>1 then begin 4451 // stack item still needs more EndList 4452 dec(Item^.PushCount); 4453 if WriteNull then begin 4454 if Item^.State=lrsowsisHeaderWritten then begin 4455 // no data yet, append EndList to header 4456 Item^.State:=lrsowsisStarted; 4457 WriteValue(vaNull); 4458 // wait again for data 4459 Item^.State:=lrsowsisHeaderWritten; 4460 end else begin 4461 // write EndList to stream 4462 WriteValue(vaNull); 4463 end; 4464 end; 4465 end else begin 4466 // stack item is complete 4467 dec(FStackPointer); 4468 //if Item^.BufCount>0 then DebugLn(['TLRSObjectWriter.Pop SKIPPED: ',Item^.Name]); 4469 if (Item^.State=lrsowsisDataWritten) and WriteNull then 4470 WriteValue(vaNull); 4471 end; 4472end; 4473 4474procedure TLRSObjectWriter.ClearStack; 4475var 4476 i: Integer; 4477begin 4478 for i:=0 to FStackCapacity-1 do begin 4479 FStack[i].Name:=''; 4480 ReAllocMem(FStack[i].Buffer,0); 4481 end; 4482 ReAllocMem(FStack,0); 4483end; 4484 4485procedure TLRSObjectWriter.FlushStackToStream; 4486var 4487 i: Integer; 4488 Item: PLRSOWStackItem; 4489begin 4490 for i:=0 to FStackPointer-1 do begin 4491 Item:=@FStack[i]; 4492 if Item^.State<>lrsowsisDataWritten then begin 4493 //DebugLn(['TLRSObjectWriter.Write FLUSH from stack to stream']); 4494 Item^.State:=lrsowsisDataWritten; 4495 WriteToStream(Item^.Buffer^,Item^.BufCount); 4496 Item^.BufCount:=0; 4497 end; 4498 end; 4499end; 4500 4501procedure TLRSObjectWriter.WriteToStream(const Buffer; Count: Longint); 4502var 4503 CopyNow: LongInt; 4504 SourceBuf: PChar; 4505begin 4506 //DebugLn(['TLRSObjectWriter.WriteToStream ',dbgMemRange(@Buffer,Count,80)]); 4507 if Count<2*FBufSize then begin 4508 // write a small amount of data 4509 SourceBuf:=@Buffer; 4510 while Count > 0 do 4511 begin 4512 CopyNow := Count; 4513 if CopyNow > FBufSize - FBufPos then 4514 CopyNow := FBufSize - FBufPos; 4515 Move(SourceBuf^, PChar(FBuffer)[FBufPos], CopyNow); 4516 Dec(Count, CopyNow); 4517 Inc(FBufPos, CopyNow); 4518 SourceBuf:=SourceBuf+CopyNow; 4519 if FBufPos = FBufSize then 4520 FlushBuffer; 4521 end; 4522 end else begin 4523 // write a big amount of data 4524 if FBufPos>0 then 4525 FlushBuffer; 4526 FStream.WriteBuffer(Buffer, Count); 4527 end; 4528end; 4529 4530procedure TLRSObjectWriter.FlushBuffer; 4531begin 4532 FStream.WriteBuffer(FBuffer^, FBufPos); 4533 FBufPos := 0; 4534end; 4535 4536procedure TLRSObjectWriter.Write(const Buffer; Count: Longint); 4537var 4538 Item: PLRSOWStackItem; 4539begin 4540 if Count=0 then exit; 4541 if (FStackPointer>0) then 4542 begin 4543 Item:=@FStack[FStackPointer-1]; 4544 case Item^.State of 4545 lrsowsisStarted: 4546 begin 4547 // store data on stack 4548 //DebugLn(['TLRSObjectWriter.Write STORE data on stack']); 4549 if Item^.BufCount+Count>Item^.BufCapacity then 4550 begin 4551 Item^.BufCapacity:=Item^.BufCount+Count+10; 4552 ReAllocMem(Item^.Buffer,Item^.BufCapacity); 4553 end; 4554 System.Move(Buffer,PByte(Item^.Buffer)[Item^.BufCount],Count); 4555 inc(Item^.BufCount,Count); 4556 exit; 4557 end; 4558 lrsowsisHeaderWritten: 4559 begin 4560 // flush header(s) from stack to stream 4561 FlushStackToStream; 4562 end; 4563 end; 4564 end; 4565 // write data to stream 4566 WriteToStream(Buffer,Count); 4567end; 4568 4569procedure TLRSObjectWriter.WriteValue(Value: TValueType); 4570var 4571 b: byte; 4572begin 4573 b:=byte(Value); 4574 Write(b, 1); 4575end; 4576 4577procedure TLRSObjectWriter.WriteStr(const Value: String); 4578var 4579 i: Integer; 4580 b: Byte; 4581begin 4582 i := Length(Value); 4583 if i > 255 then 4584 i := 255; 4585 b:=byte(i); 4586 Write(b,1); 4587 if i > 0 then 4588 Write(Value[1], i); 4589end; 4590 4591procedure TLRSObjectWriter.WriteIntegerContent(i: integer); 4592begin 4593 {$IFDEF FPC_BIG_ENDIAN} 4594 ReverseBytes(@i,4); 4595 {$ENDIF} 4596 Write(i,4); 4597end; 4598 4599procedure TLRSObjectWriter.WriteWordContent(w: word); 4600begin 4601 {$IFDEF FPC_BIG_ENDIAN} 4602 ReverseBytes(@w,2); 4603 {$ENDIF} 4604 Write(w,2); 4605end; 4606 4607procedure TLRSObjectWriter.WriteInt64Content(i: int64); 4608begin 4609 {$IFDEF FPC_BIG_ENDIAN} 4610 ReverseBytes(@i,8); 4611 {$ENDIF} 4612 Write(i,8); 4613end; 4614 4615procedure TLRSObjectWriter.WriteSingleContent(s: single); 4616begin 4617 {$IFDEF FPC_BIG_ENDIAN} 4618 ReverseBytes(@s,4); 4619 {$ENDIF} 4620 Write(s,4); 4621end; 4622 4623procedure TLRSObjectWriter.WriteDoubleContent(d: Double); 4624begin 4625 {$IFDEF FPC_BIG_ENDIAN} 4626 ReverseBytes(@d,8); 4627 {$ENDIF} 4628 Write(d,8); 4629end; 4630 4631procedure TLRSObjectWriter.WriteExtendedContent(e: Extended); 4632{$IFNDEF FPC_HAS_TYPE_EXTENDED} 4633var 4634 LRSExtended: array[1..10] of byte; 4635{$endif} 4636begin 4637 {$IFDEF FPC_HAS_TYPE_EXTENDED} 4638 {$IFDEF FPC_BIG_ENDIAN} 4639 ReverseBytes(@e,10); 4640 {$ENDIF} 4641 Write(e,10); 4642 {$ELSE} 4643 {$IFDEF FPC_BIG_ENDIAN} 4644 ConvertEndianBigDoubleToLRSExtended(@e,@LRSExtended); 4645 {$ELSE} 4646 ConvertLEDoubleToLRSExtended(@e,@LRSExtended); 4647 {$ENDIF} 4648 Write(LRSExtended,10); 4649 {$ENDIF} 4650end; 4651 4652procedure TLRSObjectWriter.WriteCurrencyContent(c: Currency); 4653begin 4654 {$IFDEF FPC_BIG_ENDIAN} 4655 ReverseBytes(@c,8); 4656 {$ENDIF} 4657 Write(c,8); 4658end; 4659 4660procedure TLRSObjectWriter.WriteWideStringContent(const ws: WideString); 4661begin 4662 if ws='' then exit; 4663 {$IFDEF FPC_BIG_ENDIAN} 4664 WriteWordsReversed(PWord(@ws[1]),length(ws)); 4665 {$ELSE} 4666 Write(ws[1],length(ws)*2); 4667 {$ENDIF} 4668end; 4669 4670procedure TLRSObjectWriter.WriteWordsReversed(p: PWord; Count: integer); 4671var 4672 i: Integer; 4673 w: Word; 4674begin 4675 for i:=0 to Count-1 do begin 4676 w:=p[i]; 4677 w:=((w and $ff) shl 8) or (w and $ff); 4678 Write(w,2); 4679 end; 4680end; 4681 4682procedure TLRSObjectWriter.WriteNulls(Count: integer); 4683var 4684 c: Char; 4685 i: Integer; 4686begin 4687 c:=#0; 4688 for i:=0 to Count-1 do Write(c,1); 4689end; 4690 4691constructor TLRSObjectWriter.Create(Stream: TStream; BufSize: Integer); 4692begin 4693 inherited Create; 4694 FStream := Stream; 4695 FBufSize := BufSize; 4696 GetMem(FBuffer, BufSize); 4697end; 4698 4699destructor TLRSObjectWriter.Destroy; 4700begin 4701 // Flush all data which hasn't been written yet 4702 if Assigned(FStream) then 4703 FlushBuffer; 4704 4705 if Assigned(FBuffer) then begin 4706 FreeMem(FBuffer, FBufSize); 4707 FBuffer:=nil; 4708 end; 4709 4710 ClearStack; 4711 4712 inherited Destroy; 4713end; 4714 4715procedure TLRSObjectWriter.BeginCollection; 4716begin 4717 //DebugLn(['TLRSObjectWriter.BeginCollection ',FStackPointer]); 4718 Push(lrsitCollection); 4719 WriteValue(vaCollection); 4720end; 4721 4722procedure TLRSObjectWriter.BeginComponent(Component: TComponent; 4723 Flags: TFilerFlags; ChildPos: Integer); 4724var 4725 Prefix: Byte; 4726 CanBeOmitted: boolean; 4727 ItemName: String; 4728 ItemRoot: TComponent; 4729begin 4730 //DebugLn(['TLRSObjectWriter.BeginComponent ',FStackPointer]); 4731 // an inherited child component can be omitted if empty 4732 CanBeOmitted:=(not WriteEmptyInheritedChilds) 4733 and (FStackPointer>0) and (ffInherited in Flags) 4734 and (not (ffChildPos in Flags)); 4735 4736 // Top component is addressed by ClassName. 4737 if FStackPointer = 0 then 4738 begin 4739 ItemName := Component.ClassName; 4740 ItemRoot := nil; 4741 end 4742 else 4743 begin 4744 ItemName := Component.Name; 4745 if Assigned(Writer) then 4746 // Writer.Root is the current Root component. 4747 ItemRoot := Writer.Root 4748 else 4749 ItemRoot := nil; 4750 end; 4751 4752 // A component has two lists: properties and childs, hence PopCount=2. 4753 Push(lrsitComponent, ItemName, ItemRoot, 2, CanBeOmitted); 4754 4755 if not FSignatureWritten then 4756 begin 4757 Write(FilerSignature[1], length(FilerSignature)); 4758 FSignatureWritten := True; 4759 end; 4760 4761 { Only write the flags if they are needed! } 4762 if Flags <> [] then 4763 begin 4764 Prefix := $f0; 4765 if ffInherited in Flags then 4766 inc(Prefix,ObjStreamMaskInherited); 4767 if ffInline in Flags then 4768 inc(Prefix,ObjStreamMaskInline); 4769 if ffChildPos in Flags then 4770 inc(Prefix,ObjStreamMaskChildPos); 4771 Write(Prefix, 1); 4772 if ffChildPos in Flags then 4773 WriteInteger(ChildPos); 4774 end; 4775 4776 WriteStr(Component.ClassName); 4777 WriteStr(Component.Name); 4778 4779 EndHeader; 4780end; 4781 4782{$IF FPC_FULLVERSION >= 30000} 4783procedure TLRSObjectWriter.WriteSignature; 4784begin 4785end; 4786{$ENDIF} 4787 4788procedure TLRSObjectWriter.BeginList; 4789begin 4790 // Increase counter for next collection item. 4791 if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then 4792 Inc(FStack[FStackPointer-1].ItemNr); 4793 //DebugLn(['TLRSObjectWriter.BeginList ',FStackPointer]); 4794 Push(lrsitList); 4795 WriteValue(vaList); 4796end; 4797 4798procedure TLRSObjectWriter.EndList; 4799begin 4800 //DebugLn(['TLRSObjectWriter.EndList ',FStackPointer]); 4801 Pop(true); 4802end; 4803 4804procedure TLRSObjectWriter.BeginProperty(const PropName: String); 4805begin 4806 //DebugLn(['TLRSObjectWriter.BeginProperty ',FStackPointer,' ',PropName]); 4807 Push(lrsitProperty, PropName); 4808 WriteStr(PropName); 4809end; 4810 4811procedure TLRSObjectWriter.EndProperty; 4812begin 4813 //DebugLn(['TLRSObjectWriter.EndProperty ',FStackPointer]); 4814 Pop(false); 4815end; 4816 4817function TLRSObjectWriter.GetStackPath: string; 4818var 4819 i: Integer; 4820 CurName: string; 4821 Item: PLRSOWStackItem; 4822begin 4823 Result:=''; 4824 4825 for i:=0 to FStackPointer-1 do 4826 begin 4827 Item := @FStack[i]; 4828 4829 // Writer.LookupRoot is the top component in the module. 4830 if Assigned(Writer) and 4831 (Item^.ItemType = lrsitComponent) and 4832 (Item^.Root = Writer.LookupRoot) and 4833 (Item^.Root <> nil) then 4834 begin 4835 // Restart path from top component. 4836 Result := Item^.Root.ClassName; 4837 end; 4838 4839 CurName:=Item^.Name; 4840 if CurName<>'' then begin 4841 if Result<>'' then Result:=Result+'.'; 4842 Result:=Result+CurName; 4843 end; 4844 if Item^.ItemNr >= 0 then 4845 Result := Result + '[' + IntToStr(Item^.ItemNr) + ']'; 4846 end; 4847end; 4848 4849procedure TLRSObjectWriter.WriteBinary(const Buffer; Count: LongInt); 4850begin 4851 WriteValue(vaBinary); 4852 WriteIntegerContent(Count); 4853 Write(Buffer, Count); 4854end; 4855 4856procedure TLRSObjectWriter.WriteBoolean(Value: Boolean); 4857begin 4858 if Value then 4859 WriteValue(vaTrue) 4860 else 4861 WriteValue(vaFalse); 4862end; 4863 4864procedure TLRSObjectWriter.WriteFloat(const Value: Extended); 4865begin 4866 WriteValue(vaExtended); 4867 WriteExtendedContent(Value); 4868end; 4869 4870procedure TLRSObjectWriter.WriteSingle(const Value: Single); 4871begin 4872 WriteValue(vaSingle); 4873 WriteSingleContent(Value); 4874end; 4875 4876procedure TLRSObjectWriter.WriteCurrency(const Value: Currency); 4877begin 4878 WriteValue(vaCurrency); 4879 WriteCurrencyContent(Value); 4880end; 4881 4882procedure TLRSObjectWriter.WriteDate(const Value: TDateTime); 4883begin 4884 WriteValue(vaDate); 4885 WriteDoubleContent(Value); 4886end; 4887 4888procedure TLRSObjectWriter.WriteIdent(const Ident: string); 4889begin 4890 { Check if Ident is a special identifier before trying to just write 4891 Ident directly } 4892 if UpperCase(Ident) = 'NIL' then 4893 WriteValue(vaNil) 4894 else if UpperCase(Ident) = 'FALSE' then 4895 WriteValue(vaFalse) 4896 else if UpperCase(Ident) = 'TRUE' then 4897 WriteValue(vaTrue) 4898 else if UpperCase(Ident) = 'NULL' then 4899 WriteValue(vaNull) else 4900 begin 4901 WriteValue(vaIdent); 4902 WriteStr(Ident); 4903 end; 4904end; 4905 4906procedure TLRSObjectWriter.WriteInteger(Value: Int64); 4907var 4908 w: Word; 4909 i: Integer; 4910 b: Byte; 4911begin 4912 //debugln('TLRSObjectWriter.WriteInteger Value=',Value); 4913 // Use the smallest possible integer type for the given value: 4914 if (Value >= -128) and (Value <= 127) then 4915 begin 4916 WriteValue(vaInt8); 4917 b:=Byte(Value); 4918 Write(b, 1); 4919 end else if (Value >= -32768) and (Value <= 32767) then 4920 begin 4921 WriteValue(vaInt16); 4922 w:=Word(Value); 4923 WriteWordContent(w); 4924 end else if (Value >= -$80000000) and (Value <= $7fffffff) then 4925 begin 4926 WriteValue(vaInt32); 4927 i:=Integer(Value); 4928 WriteIntegerContent(i); 4929 end else 4930 begin 4931 WriteValue(vaInt64); 4932 WriteInt64Content(Value); 4933 end; 4934end; 4935 4936procedure TLRSObjectWriter.WriteMethodName(const Name: String); 4937begin 4938 if Length(Name) > 0 then 4939 begin 4940 WriteValue(vaIdent); 4941 WriteStr(Name); 4942 end else 4943 WriteValue(vaNil); 4944end; 4945 4946procedure TLRSObjectWriter.WriteSet(Value: LongInt; SetType: Pointer); 4947type 4948 tset = set of 0..31; 4949var 4950 i: Integer; 4951begin 4952 WriteValue(vaSet); 4953 for i := 0 to 31 do 4954 begin 4955 if (i in tset(Value)) then 4956 WriteStr(GetEnumName(PTypeInfo(SetType), i)); 4957 end; 4958 WriteStr(''); 4959end; 4960 4961procedure TLRSObjectWriter.WriteString(const Value: String); 4962var 4963 i: Integer; 4964 b: Byte; 4965begin 4966 i := Length(Value); 4967 if i <= 255 then 4968 begin 4969 WriteValue(vaString); 4970 b:=byte(i); 4971 Write(b, 1); 4972 end else 4973 begin 4974 WriteValue(vaLString); 4975 WriteIntegerContent(i); 4976 end; 4977 if i > 0 then 4978 Write(Value[1], i); 4979end; 4980 4981procedure TLRSObjectWriter.WriteWideString(const Value: WideString); 4982var 4983 i: Integer; 4984begin 4985 WriteValue(vaWString); 4986 i := Length(Value); 4987 WriteIntegerContent(i); 4988 WriteWideStringContent(Value); 4989end; 4990 4991procedure TLRSObjectWriter.WriteUnicodeString(const Value: UnicodeString); 4992var 4993 i: Integer; 4994begin 4995 WriteValue(vaUString); 4996 i := Length(Value); 4997 WriteIntegerContent(i); 4998 WriteWideStringContent(Value); 4999end; 5000 5001procedure TLRSObjectWriter.WriteVariant(const Value: Variant); 5002begin 5003 case VarType(Value) of 5004 varnull: 5005 WriteValue(vaNull); 5006 varsmallint, varinteger, varshortint, varint64, varbyte, varword, varlongword, varqword: 5007 WriteInteger(Value); 5008 varsingle: 5009 WriteSingle(Value); 5010 vardouble: 5011 WriteFloat(Value); 5012 vardate: 5013 WriteDate(Value); 5014 varcurrency: 5015 WriteCurrency(Value); 5016 varolestr, varstring: 5017 WriteString(Value); 5018 varboolean: 5019 WriteBoolean(Value); 5020 else 5021 WriteValue(vaNil); 5022 end; 5023end; 5024 5025{ TLRPositionLinks } 5026 5027function TLRPositionLinks.GetLFM(Index: integer): Int64; 5028begin 5029 Result:=PLRPositionLink(FItems[Index])^.LFMPosition; 5030end; 5031 5032function TLRPositionLinks.GetData(Index: integer): Pointer; 5033begin 5034 Result:=PLRPositionLink(FItems[Index])^.Data; 5035end; 5036 5037function TLRPositionLinks.GetLRS(Index: integer): Int64; 5038begin 5039 Result:=PLRPositionLink(FItems[Index])^.LRSPosition; 5040end; 5041 5042procedure TLRPositionLinks.SetCount(const AValue: integer); 5043var 5044 i: LongInt; 5045 Item: PLRPositionLink; 5046begin 5047 if FCount=AValue then exit; 5048 // free old items 5049 for i:=AValue to FCount-1 do begin 5050 Item:=PLRPositionLink(FItems[i]); 5051 Dispose(Item); 5052 end; 5053 // create new items 5054 FItems.Count:=AValue; 5055 for i:=FCount to AValue-1 do begin 5056 New(Item); 5057 Item^.LFMPosition:=-1; 5058 Item^.LRSPosition:=-1; 5059 Item^.Data:=nil; 5060 FItems[i]:=Item; 5061 end; 5062 FCount:=AValue; 5063end; 5064 5065procedure TLRPositionLinks.SetData(Index: integer; const AValue: Pointer); 5066begin 5067 PLRPositionLink(FItems[Index])^.Data:=AValue; 5068end; 5069 5070procedure TLRPositionLinks.SetLFM(Index: integer; const AValue: Int64); 5071begin 5072 PLRPositionLink(FItems[Index])^.LFMPosition:=AValue; 5073end; 5074 5075procedure TLRPositionLinks.SetLRS(Index: integer; const AValue: Int64); 5076begin 5077 PLRPositionLink(FItems[Index])^.LRSPosition:=AValue; 5078end; 5079 5080constructor TLRPositionLinks.Create; 5081begin 5082 FItems:=TFPList.Create; 5083end; 5084 5085destructor TLRPositionLinks.Destroy; 5086begin 5087 Count:=0; 5088 FItems.Free; 5089 inherited Destroy; 5090end; 5091 5092procedure TLRPositionLinks.Clear; 5093begin 5094 Count:=0; 5095end; 5096 5097procedure TLRPositionLinks.Sort(LFMPositions: Boolean); 5098begin 5099 if LFMPositions then 5100 FItems.Sort(@CompareLRPositionLinkWithLFMPosition) 5101 else 5102 FItems.Sort(@CompareLRPositionLinkWithLRSPosition) 5103end; 5104 5105function TLRPositionLinks.IndexOf(const Position: int64; LFMPositions: Boolean 5106 ): integer; 5107var 5108 l, r, m: integer; 5109 p: Int64; 5110begin 5111 // binary search for the line 5112 l:=0; 5113 r:=FCount-1; 5114 while r>=l do begin 5115 m:=(l+r) shr 1; 5116 if LFMPositions then 5117 p:=PLRPositionLink(FItems[m])^.LFMPosition 5118 else 5119 p:=PLRPositionLink(FItems[m])^.LRSPosition; 5120 if p>Position then begin 5121 // too high, search lower 5122 r:=m-1; 5123 end else if p<Position then begin 5124 // too low, search higher 5125 l:=m+1; 5126 end else begin 5127 // position found 5128 Result:=m; 5129 exit; 5130 end; 5131 end; 5132 Result:=-1; 5133end; 5134 5135function TLRPositionLinks.IndexOfRange(const FromPos, ToPos: int64; 5136 LFMPositions: Boolean): integer; 5137var 5138 l, r, m: integer; 5139 p: Int64; 5140 Item: PLRPositionLink; 5141begin 5142 // binary search for the line 5143 l:=0; 5144 r:=FCount-1; 5145 while r>=l do begin 5146 m:=(l+r) shr 1; 5147 Item:=PLRPositionLink(FItems[m]); 5148 if LFMPositions then 5149 p:=Item^.LFMPosition 5150 else 5151 p:=Item^.LRSPosition; 5152 if p>=ToPos then begin 5153 // too high, search lower 5154 r:=m-1; 5155 end else if p<FromPos then begin 5156 // too low, search higher 5157 l:=m+1; 5158 end else begin 5159 // position found 5160 Result:=m; 5161 exit; 5162 end; 5163 end; 5164 Result:=-1; 5165end; 5166 5167procedure TLRPositionLinks.SetPosition(const FromPos, ToPos, MappedPos: int64; 5168 LFMtoLRSPositions: Boolean); 5169var 5170 i: LongInt; 5171begin 5172 i:=IndexOfRange(FromPos,ToPos,LFMtoLRSPositions); 5173 if i>=0 then 5174 if LFMtoLRSPositions then 5175 PLRPositionLink(FItems[i])^.LRSPosition:=MappedPos 5176 else 5177 PLRPositionLink(FItems[i])^.LFMPosition:=MappedPos; 5178end; 5179 5180procedure TLRPositionLinks.Add(const LFMPos, LRSPos: Int64; AData: Pointer); 5181var 5182 Item: PLRPositionLink; 5183begin 5184 Count:=Count+1; 5185 Item:=PLRPositionLink(FItems[Count-1]); 5186 Item^.LFMPosition:=LFMPos; 5187 Item^.LRSPosition:=LRSPos; 5188 Item^.Data:=AData; 5189end; 5190 5191{ TCustomLazComponentQueue } 5192 5193function TCustomLazComponentQueue.ReadComponentSize(out ComponentSize, 5194 SizeLength: int64): Boolean; 5195// returns true if there are enough bytes to read the ComponentSize 5196// and returns the ComponentSize 5197// and returns the size (SizeLength) needed to store the ComponentSize 5198 5199 procedure ReadBytes(var p); 5200 var a: array[1..9] of byte; 5201 begin 5202 FQueue.Top(a[1],1+SizeLength); 5203 System.Move(a[2],p,SizeLength); 5204 {$IFDEF FPC_BIG_ENDIAN} 5205 ReverseBytes(@p,SizeLength); 5206 {$ENDIF} 5207 end; 5208 5209var 5210 v8: ShortInt; 5211 v16: SmallInt; 5212 v32: Integer; 5213 v64: int64; 5214 vt: TValueType; 5215begin 5216 Result:=false; 5217 // check if there are enough bytes 5218 if (FQueue.Size<2) then exit; 5219 FQueue.Top(vt,1); 5220 case vt of 5221 vaInt8: SizeLength:=1; 5222 vaInt16: SizeLength:=2; 5223 vaInt32: SizeLength:=4; 5224 vaInt64: SizeLength:=8; 5225 else 5226 raise EInOutError.Create('Invalid size type'); 5227 end; 5228 if FQueue.Size<1+SizeLength then exit; // need more data 5229 // read the ComponentSize 5230 Result:=true; 5231 case vt of 5232 vaInt8: 5233 begin 5234 ReadBytes(v8); 5235 ComponentSize:=v8; 5236 end; 5237 vaInt16: 5238 begin 5239 ReadBytes(v16); 5240 ComponentSize:=v16; 5241 end; 5242 vaInt32: 5243 begin 5244 ReadBytes(v32); 5245 ComponentSize:=v32; 5246 end; 5247 vaInt64: 5248 begin 5249 ReadBytes(v64); 5250 ComponentSize:=v64; 5251 end; 5252 end; 5253 inc(SizeLength); 5254 if ComponentSize<0 then 5255 raise EInOutError.Create('Size of data in queue is negative'); 5256end; 5257 5258constructor TCustomLazComponentQueue.Create(TheOwner: TComponent); 5259begin 5260 inherited Create(TheOwner); 5261 FQueue:=TDynamicDataQueue.Create; 5262end; 5263 5264destructor TCustomLazComponentQueue.Destroy; 5265begin 5266 FreeAndNil(FQueue); 5267 inherited Destroy; 5268end; 5269 5270procedure TCustomLazComponentQueue.Clear; 5271begin 5272 FQueue.Clear; 5273end; 5274 5275function TCustomLazComponentQueue.Write(const Buffer; Count: Longint): Longint; 5276begin 5277 Result:=FQueue.Push(Buffer,Count); 5278end; 5279 5280function TCustomLazComponentQueue.CopyFrom(AStream: TStream; Count: Longint 5281 ): Longint; 5282begin 5283 Result:=FQueue.Push(AStream,Count); 5284end; 5285 5286function TCustomLazComponentQueue.HasComponent: Boolean; 5287var 5288 ComponentSize, SizeLength: int64; 5289begin 5290 if not ReadComponentSize(ComponentSize,SizeLength) then exit(false); 5291 Result:=FQueue.Size-SizeLength>=ComponentSize; 5292end; 5293 5294function TCustomLazComponentQueue.ReadComponent(var AComponent: TComponent; 5295 NewOwner: TComponent): Boolean; 5296var 5297 ComponentSize, SizeLength: int64; 5298 AStream: TMemoryStream; 5299begin 5300 Result:=false; 5301 if not ReadComponentSize(ComponentSize,SizeLength) then exit; 5302 if (FQueue.Size-SizeLength<ComponentSize) then exit; 5303 // a complete component is in the buffer -> copy it to a stream 5304 AStream:=TMemoryStream.Create; 5305 try 5306 // copy component to stream 5307 AStream.Size:=SizeLength+ComponentSize; 5308 FQueue.Pop(AStream,SizeLength+ComponentSize); 5309 // create/read the component 5310 AStream.Position:=SizeLength; 5311 ReadComponentFromBinaryStream(AStream,AComponent, 5312 OnFindComponentClass,NewOwner); 5313 finally 5314 AStream.Free; 5315 end; 5316 Result:=true; 5317end; 5318 5319function TCustomLazComponentQueue.ConvertComponentAsString(AComponent: TComponent 5320 ): string; 5321var 5322 AStream: TMemoryStream; 5323 ComponentSize: Int64; 5324 LengthSize: Int64; 5325begin 5326 // write component to stream 5327 AStream:=TMemoryStream.Create; 5328 try 5329 WriteComponentAsBinaryToStream(AStream,AComponent); 5330 5331 ComponentSize:=AStream.Size; 5332 WriteLRSInt64MB(AStream,ComponentSize); 5333 LengthSize:=AStream.Size-ComponentSize; 5334 //debugln('TCustomLazComponentQueue.ConvertComponentAsString ComponentSize=',ComponentSize,' LengthSize=',LengthSize); 5335 5336 SetLength(Result,AStream.Size); 5337 // write size 5338 AStream.Position:=ComponentSize; 5339 AStream.Read(Result[1],LengthSize); 5340 //debugln('TCustomLazComponentQueue.ConvertComponentAsString ',hexstr(ord(Result[1]),2),' ',hexstr(ord(Result[2]),2),' ',hexstr(ord(Result[3]),2),' ',hexstr(ord(Result[4]),2)); 5341 // write component 5342 AStream.Position:=0; 5343 AStream.Read(Result[LengthSize+1],ComponentSize); 5344 finally 5345 AStream.Free; 5346 end; 5347end; 5348 5349{ TLazarusResourceStream } 5350 5351procedure TLazarusResourceStream.Initialize(Name, ResType: PChar); 5352begin 5353 if ResType <> nil then 5354 FLRes := LazarusResources.Find(Name, ResType) 5355 else 5356 FLRes := LazarusResources.Find(Name); 5357 5358 if FLRes = nil then 5359 raise EResNotFound.CreateFmt(SResNotFound, [Name]); 5360 SetPointer(PChar(FLRes.Value), Length(FLRes.Value)); 5361end; 5362 5363constructor TLazarusResourceStream.Create(const ResName: string; ResType: PChar); 5364begin 5365 inherited Create; 5366 Initialize(PChar(ResName), ResType); 5367end; 5368 5369constructor TLazarusResourceStream.CreateFromID(ResID: Integer; ResType: PChar); 5370begin 5371 inherited Create; 5372 Initialize(PChar(PtrInt(ResID)), ResType); 5373end; 5374 5375constructor TLazarusResourceStream.CreateFromHandle(AHandle: TLResource); 5376begin 5377 inherited Create; 5378 FLRes := AHandle; 5379 SetPointer(PChar(FLRes.Value), Length(FLRes.Value)); 5380end; 5381 5382{$ifdef UseRes} 5383constructor TLazarusResourceStream.CreateFromHandle(Instance: TFPResourceHMODULE; AHandle: TFPResourceHandle); 5384begin 5385 FPRes := LoadResource(Instance, AHandle); 5386 if FPRes <> 0 then 5387 SetPointer(LockResource(FPRes), SizeOfResource(Instance, AHandle)); 5388end; 5389{$endif} 5390 5391destructor TLazarusResourceStream.Destroy; 5392begin 5393{$ifdef UseRES} 5394 if FPRes <> 0 then 5395 begin 5396 UnlockResource(FPRes); 5397 FreeResource(FPRes); 5398 end; 5399{$endif} 5400 inherited Destroy; 5401end; 5402 5403function TLazarusResourceStream.Write(const Buffer; Count: Longint): Longint; 5404begin 5405 Result := 0; 5406 raise EStreamError.Create(SCantWriteResourceStreamError); 5407end; 5408 5409const 5410 ParseBufSize = 4096; 5411 LastSpecialToken = 5; 5412 5413 TokNames : array[0..LastSpecialToken] of string = 5414 ( 5415 'EOF', 5416 'Symbol', 5417 'String', 5418 'Integer', 5419 'Float', 5420 'WideString' 5421 ); 5422 5423function TUTF8Parser.GetTokenName(aTok: char): string; 5424begin 5425 if ord(aTok) <= LastSpecialToken then 5426 Result:=TokNames[ord(aTok)] 5427 else Result:=aTok; 5428end; 5429 5430procedure TUTF8Parser.LoadBuffer; 5431var newread : integer; 5432begin 5433 newread:=fStream.Read(fBuf[0],ParseBufSize); 5434 fBuf[newread]:=#0; 5435 fLineStart:=fLineStart-fPos; // column = fPos - fLineStart + 1 5436 fPos:=0; 5437 fBufLen:=newread; 5438 fEofReached:=newread=0; 5439end; 5440 5441procedure TUTF8Parser.CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 5442begin 5443 if fBuf[fPos]<>#0 then exit; 5444 if fPos<fBufLen then begin 5445 // skip #0 5446 repeat 5447 inc(fPos); 5448 if fBuf[fPos]<>#0 then exit; 5449 until (fPos=fBufLen); 5450 end; 5451 LoadBuffer; 5452end; 5453 5454procedure TUTF8Parser.ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 5455begin 5456 fLastTokenStr:=fLastTokenStr+fBuf[fPos]; 5457 inc(fPos); 5458 CheckLoadBuffer; 5459end; 5460 5461function TUTF8Parser.IsNumber: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 5462begin 5463 Result:=fBuf[fPos] in ['0'..'9']; 5464end; 5465 5466function TUTF8Parser.IsHexNum: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 5467begin 5468 Result:=fBuf[fPos] in ['0'..'9','A'..'F','a'..'f']; 5469end; 5470 5471function TUTF8Parser.IsAlpha: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 5472begin 5473 Result:=fBuf[fPos] in ['_','A'..'Z','a'..'z']; 5474end; 5475 5476function TUTF8Parser.IsAlphaNum: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 5477begin 5478 Result:=IsAlpha or IsNumber; 5479end; 5480 5481function TUTF8Parser.GetHexValue(c: char): byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 5482begin 5483 case c of 5484 '0'..'9' : Result:=ord(c)-$30; 5485 'A'..'F' : Result:=ord(c)-$37; //-$41+$0A 5486 'a'..'f' : Result:=ord(c)-$57; //-$61+$0A 5487 end; 5488end; 5489 5490function TUTF8Parser.GetAlphaNum: string; 5491begin 5492 if not IsAlpha then 5493 ErrorFmt(SParExpected,[GetTokenName(toSymbol)]); 5494 Result:=''; 5495 while IsAlphaNum do 5496 begin 5497 Result:=Result+fBuf[fPos]; 5498 inc(fPos); 5499 CheckLoadBuffer; 5500 end; 5501end; 5502 5503procedure TUTF8Parser.HandleNewLine; 5504begin 5505 if fBuf[fPos]=#13 then //CR 5506 begin 5507 inc(fPos); 5508 CheckLoadBuffer; 5509 if fBuf[fPos]=#10 then inc(fPos); //CR LF 5510 end 5511 else 5512 inc(fPos); //LF 5513 CheckLoadBuffer; 5514 inc(fSourceLine); 5515 fLineStart:=fPos; 5516end; 5517 5518procedure TUTF8Parser.SkipSpaces; 5519begin 5520 while fBuf[fPos] in [' ',#9] do begin 5521 inc(fPos); 5522 CheckLoadBuffer; 5523 end; 5524end; 5525 5526procedure TUTF8Parser.SkipWhitespace; 5527begin 5528 while true do 5529 begin 5530 case fBuf[fPos] of 5531 ' ',#9 : SkipSpaces; 5532 #10,#13 : HandleNewLine 5533 else break; 5534 end; 5535 end; 5536end; 5537 5538procedure TUTF8Parser.HandleEof; 5539begin 5540 fToken:=toEOF; 5541 fLastTokenStr:=''; 5542end; 5543 5544procedure TUTF8Parser.HandleAlphaNum; 5545begin 5546 fLastTokenStr:=GetAlphaNum; 5547 fToken:=toSymbol; 5548end; 5549 5550procedure TUTF8Parser.HandleNumber; 5551type 5552 floatPunct = (fpDot,fpE); 5553 floatPuncts = set of floatPunct; 5554var 5555 allowed : floatPuncts; 5556begin 5557 fLastTokenStr:=''; 5558 while IsNumber do 5559 ProcessChar; 5560 fToken:=toInteger; 5561 if (fBuf[fPos] in ['.','e','E']) then 5562 begin 5563 fToken:=toFloat; 5564 allowed:=[fpDot,fpE]; 5565 while (fBuf[fPos] in ['.','e','E','0'..'9']) do 5566 begin 5567 case fBuf[fPos] of 5568 '.' : if fpDot in allowed then Exclude(allowed,fpDot) else break; 5569 'E','e' : if fpE in allowed then 5570 begin 5571 allowed:=[]; 5572 ProcessChar; 5573 if (fBuf[fPos] in ['+','-']) then ProcessChar; 5574 if not (fBuf[fPos] in ['0'..'9']) then 5575 ErrorFmt(SParInvalidFloat,[fLastTokenStr+fBuf[fPos]]); 5576 end 5577 else break; 5578 end; 5579 ProcessChar; 5580 end; 5581 end; 5582 if (fBuf[fPos] in ['s','S','d','D','c','C']) then //single, date, currency 5583 begin 5584 fFloatType:=fBuf[fPos]; 5585 inc(fPos); 5586 CheckLoadBuffer; 5587 fToken:=toFloat; 5588 end 5589 else fFloatType:=#0; 5590end; 5591 5592procedure TUTF8Parser.HandleHexNumber; 5593var valid : boolean; 5594begin 5595 fLastTokenStr:='$'; 5596 inc(fPos); 5597 CheckLoadBuffer; 5598 valid:=false; 5599 while IsHexNum do 5600 begin 5601 valid:=true; 5602 ProcessChar; 5603 end; 5604 if not valid then 5605 ErrorFmt(SParInvalidInteger,[fLastTokenStr]); 5606 fToken:=toInteger; 5607end; 5608 5609function TUTF8Parser.HandleQuotedString: string; 5610begin 5611 Result:=''; 5612 inc(fPos); 5613 CheckLoadBuffer; 5614 while true do 5615 begin 5616 case fBuf[fPos] of 5617 #0 : ErrorStr(SParUnterminatedString); 5618 #13,#10 : ErrorStr(SParUnterminatedString); 5619 '''' : begin 5620 inc(fPos); 5621 CheckLoadBuffer; 5622 if fBuf[fPos]<>'''' then exit; 5623 end; 5624 end; 5625 Result:=Result+fBuf[fPos]; 5626 inc(fPos); 5627 CheckLoadBuffer; 5628 end; 5629end; 5630 5631function TUTF8Parser.HandleDecimalString: string; 5632var 5633 i: integer; 5634begin 5635 Result:=''; 5636 inc(fPos); 5637 CheckLoadBuffer; 5638 while IsNumber do 5639 begin 5640 Result:=Result+fBuf[fPos]; 5641 inc(fPos); 5642 CheckLoadBuffer; 5643 end; 5644 if not TryStrToInt(Result,i) then 5645 i:=0; 5646 Result:=UnicodeToUTF8(i); // widestring 5647end; 5648 5649procedure TUTF8Parser.HandleString; 5650var 5651 IsWideString: Boolean; 5652begin 5653 fLastTokenStr:=''; 5654 IsWideString := false; 5655 while true do begin 5656 case fBuf[fPos] of 5657 '''' : fLastTokenStr:=fLastTokenStr+HandleQuotedString; 5658 '#' : begin 5659 fLastTokenStr:=fLastTokenStr+HandleDecimalString; 5660 IsWideString:=true; 5661 end; 5662 else break; 5663 end; 5664 end; 5665 if IsWideString then 5666 fToken:=Classes.toWString 5667 else 5668 fToken:=Classes.toString; 5669end; 5670 5671procedure TUTF8Parser.HandleMinus; 5672begin 5673 inc(fPos); 5674 CheckLoadBuffer; 5675 if IsNumber then 5676 begin 5677 HandleNumber; 5678 fLastTokenStr:='-'+fLastTokenStr; 5679 end 5680 else 5681 begin 5682 fToken:='-'; 5683 fLastTokenStr:=fToken; 5684 end; 5685end; 5686 5687procedure TUTF8Parser.HandleUnknown; 5688begin 5689 fToken:=fBuf[fPos]; 5690 fLastTokenStr:=fToken; 5691 inc(fPos); 5692 CheckLoadBuffer; 5693end; 5694 5695constructor TUTF8Parser.Create(Stream: TStream); 5696begin 5697 fStream:=Stream; 5698 fBuf:=GetMem(ParseBufSize+1); 5699 fBufLen:=0; 5700 fPos:=0; 5701 fLineStart:=0; 5702 fSourceLine:=1; 5703 fEofReached:=false; 5704 fLastTokenStr:=''; 5705 fFloatType:=#0; 5706 fToken:=#0; 5707 LoadBuffer; 5708 NextToken; 5709end; 5710 5711destructor TUTF8Parser.Destroy; 5712begin 5713 fStream.Position:=SourcePos; 5714 FreeMem(fBuf); 5715end; 5716 5717procedure TUTF8Parser.CheckToken(T: Char); 5718begin 5719 if fToken<>T then 5720 ErrorFmt(SParWrongTokenType,[GetTokenName(T),GetTokenName(fToken)]); 5721end; 5722 5723procedure TUTF8Parser.CheckTokenSymbol(const S: string); 5724begin 5725 CheckToken(toSymbol); 5726 if CompareText(fLastTokenStr,S)<>0 then 5727 ErrorFmt(SParWrongTokenSymbol,[s,fLastTokenStr]); 5728end; 5729 5730procedure TUTF8Parser.Error(const Ident: string); 5731begin 5732 ErrorStr(Ident); 5733end; 5734 5735procedure TUTF8Parser.ErrorFmt(const Ident: string; const Args: array of const); 5736begin 5737 ErrorStr(Format(Ident,Args)); 5738end; 5739 5740procedure TUTF8Parser.ErrorStr(const Message: string); 5741begin 5742 debugln(['TUTF8Parser.ErrorStr Message="',Message,'" at y=',SourceLine,',x=',SourceColumn]); 5743 raise EParserError.CreateFmt(Message+SParLocInfo,[SourceLine,SourceColumn,SourcePos]); 5744end; 5745 5746procedure TUTF8Parser.HexToBinary(Stream: TStream); 5747var outbuf : array[0..ParseBufSize-1] of byte; 5748 b : byte; 5749 i : integer; 5750begin 5751 i:=0; 5752 SkipWhitespace; 5753 while IsHexNum do 5754 begin 5755 b:=(GetHexValue(fBuf[fPos]) shl 4); 5756 inc(fPos); 5757 CheckLoadBuffer; 5758 if not IsHexNum then 5759 Error(SParUnterminatedBinValue); 5760 b:=b or GetHexValue(fBuf[fPos]); 5761 inc(fPos); 5762 CheckLoadBuffer; 5763 outbuf[i]:=b; 5764 inc(i); 5765 if i>=ParseBufSize then 5766 begin 5767 Stream.WriteBuffer(outbuf[0],i); 5768 i:=0; 5769 end; 5770 SkipWhitespace; 5771 end; 5772 if i>0 then 5773 Stream.WriteBuffer(outbuf[0],i); 5774 NextToken; 5775end; 5776 5777function TUTF8Parser.NextToken: Char; 5778 5779begin 5780 SkipWhiteSpace; 5781 if fEofReached then 5782 HandleEof 5783 else 5784 case fBuf[fPos] of 5785 '_','A'..'Z','a'..'z' : HandleAlphaNum; 5786 '$' : HandleHexNumber; 5787 '-' : HandleMinus; 5788 '0'..'9' : HandleNumber; 5789 '''','#' : HandleString 5790 else 5791 HandleUnknown; 5792 end; 5793 Result:=fToken; 5794end; 5795 5796function TUTF8Parser.SourcePos: Longint; 5797begin 5798 Result:=fStream.Position-fBufLen+fPos; 5799end; 5800 5801function TUTF8Parser.TokenComponentIdent: string; 5802begin 5803 if fToken<>toSymbol then 5804 ErrorFmt(SParExpected,[GetTokenName(toSymbol)]); 5805 CheckLoadBuffer; 5806 while fBuf[fPos]='.' do 5807 begin 5808 ProcessChar; 5809 fLastTokenStr:=fLastTokenStr+GetAlphaNum; 5810 end; 5811 Result:=fLastTokenStr; 5812end; 5813 5814function TUTF8Parser.TokenFloat: Extended; 5815 5816var errcode : word; 5817 5818begin 5819 Val(fLastTokenStr,Result,errcode); 5820 if errcode<>0 then 5821 ErrorFmt(SParInvalidFloat,[fLastTokenStr]); 5822end; 5823 5824function TUTF8Parser.TokenInt: Int64; 5825begin 5826 if not TryStrToInt64(fLastTokenStr,Result) then 5827 Result:=Int64(StrToQWord(fLastTokenStr)); //second chance for malformed files 5828end; 5829 5830function TUTF8Parser.TokenString: string; 5831begin 5832 case fToken of 5833 toFloat : if fFloatType<>#0 then 5834 Result:=fLastTokenStr+fFloatType 5835 else Result:=fLastTokenStr 5836 else 5837 Result:=fLastTokenStr; 5838 end; 5839end; 5840 5841function TUTF8Parser.TokenSymbolIs(const S: string): Boolean; 5842begin 5843 Result:=(fToken=toSymbol) and (CompareText(fLastTokenStr,S)=0); 5844end; 5845 5846function TUTF8Parser.SourceColumn: integer; 5847begin 5848 Result:=fPos-fLineStart+1; 5849end; 5850 5851//------------------------------------------------------------------------------ 5852procedure InternalInit; 5853begin 5854 LazarusResources := TLResourceList.Create; 5855 RegisterInitComponentHandler(TComponent, @InitResourceComponent); 5856 PropertiesToSkip := TPropertiesToSkip.Create; 5857end; 5858 5859initialization 5860 InternalInit; 5861 5862finalization 5863 FreeAndNil(LazarusResources); 5864 FreeAndNil(PropertiesToSkip); 5865 5866end. 5867 5868 5869 5870