1{ 2 This file is part of the Free Pascal Run Time Library (rtl) 3 Copyright (c) 1999-2008 by Michael Van Canneyt, Florian Klaempfl, 4 and Micha Nelissen 5 6 See the file COPYING.FPC, included in this distribution, 7 for details about the copyright. 8 9 This program is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 12 13 **********************************************************************} 14 15{$H+} 16 17 18{$ifdef CLASSESINLINE}{$inline on}{$endif} 19 20 21type 22 { extra types to compile with FPC } 23 HRSRC = TFPResourceHandle deprecated; 24 TComponentName = string; 25 THandle = System.THandle; 26 27 TPoint=Types.TPoint; 28 TRect=Types.TRect; 29 TSmallPoint=Types.TSmallPoint; 30 31{$ifndef FPC_HAS_FEATURE_DYNLIBS} 32 HMODULE = ptrint; 33{$else} 34 HModule = System.HModule; 35{$endif} 36 37const 38 39{ Maximum TList size } 40 41{$ifdef cpu16} 42 MaxListSize = {Maxint div 16}1024; 43{$else cpu16} 44 MaxListSize = Maxint div 16; 45{$endif cpu16} 46 47{ values for TShortCut } 48 49 scShift = $2000; 50 scCtrl = $4000; 51 scAlt = $8000; 52 scNone = 0; 53 54{ TStream seek origins } 55const 56 soFromBeginning = 0; 57 soFromCurrent = 1; 58 soFromEnd = 2; 59 60type 61 TSeekOrigin = (soBeginning, soCurrent, soEnd); 62 TDuplicates = Types.TDuplicates; 63 64// For Delphi and backwards compatibility. 65const 66 dupIgnore = Types.dupIgnore; 67 dupAccept = Types.dupAccept; 68 dupError = Types.dupError; 69 70{ TFileStream create mode } 71const 72 fmCreate = $FF00; 73 fmOpenRead = 0; 74 fmOpenWrite = 1; 75 fmOpenReadWrite = 2; 76 77{ TParser special tokens } 78 79 toEOF = Char(0); 80 toSymbol = Char(1); 81 toString = Char(2); 82 toInteger = Char(3); 83 toFloat = Char(4); 84 toWString = Char(5); 85 86Const 87 FilerSignature : Array[1..4] of char = 'TPF0'; 88 89type 90{ Text alignment types } 91 TAlignment = (taLeftJustify, taRightJustify, taCenter); 92 93 TLeftRight = taLeftJustify..taRightJustify; 94 TVerticalAlignment = (taAlignTop, taAlignBottom, taVerticalCenter); 95 TTopBottom = taAlignTop..taAlignBottom; 96 97 TBiDiMode = (bdLeftToRight,bdRightToLeft,bdRightToLeftNoAlign,bdRightToLeftReadingOnly); 98 99 100{ Types used by standard events } 101 TShiftStateEnum = (ssShift, ssAlt, ssCtrl, 102 ssLeft, ssRight, ssMiddle, ssDouble, 103 // Extra additions 104 ssMeta, ssSuper, ssHyper, ssAltGr, ssCaps, ssNum, 105 ssScroll,ssTriple,ssQuad,ssExtra1,ssExtra2); 106 107{$packset 1} 108 TShiftState = set of TShiftStateEnum; 109{$packset default} 110 111 THelpContext = -MaxLongint..MaxLongint; 112 THelpType = (htKeyword, htContext); 113 114 TShortCut = Low(Word)..High(Word); 115 116{ Standard events } 117 118 TNotifyEvent = procedure(Sender: TObject) of object; 119 THelpEvent = function (Command: Word; Data: Longint; 120 var CallHelp: Boolean): Boolean of object; 121 TGetStrProc = procedure(const S: string) of object; 122 123{ Exception classes } 124 125 EStreamError = class(Exception); 126 EFCreateError = class(EStreamError); 127 EFOpenError = class(EStreamError); 128 EFilerError = class(EStreamError); 129 EReadError = class(EFilerError); 130 EWriteError = class(EFilerError); 131 EClassNotFound = class(EFilerError); 132 EMethodNotFound = class(EFilerError); 133 EInvalidImage = class(EFilerError); 134 EResNotFound = class(Exception); 135{$ifdef FPC_TESTGENERICS} 136 EListError = fgl.EListError; 137{$else} 138 EListError = class(Exception); 139{$endif} 140 EBitsError = class(Exception); 141 EStringListError = class(Exception); 142 EComponentError = class(Exception); 143 EParserError = class(Exception); 144 EOutOfResources = class(EOutOfMemory); 145 EInvalidOperation = class(Exception); 146 TExceptionClass = Class of Exception; 147 148{ --------------------------------------------------------------------- 149 Free Pascal Observer support 150 ---------------------------------------------------------------------} 151 152 153Const 154 SGUIDObserved = '{663C603C-3F3C-4CC5-823C-AC8079F979E5}'; 155 SGUIDObserver = '{BC7376EA-199C-4C2A-8684-F4805F0691CA}'; 156 157Type 158 // Notification operations : 159 // Observer has changed, is freed, item added to/deleted from list, custom event. 160 TFPObservedOperation = (ooChange,ooFree,ooAddItem,ooDeleteItem,ooCustom); 161{$INTERFACES CORBA} 162 163 { IFPObserved } 164 165 IFPObserved = Interface [SGUIDObserved] 166 // attach a new observer 167 Procedure FPOAttachObserver(AObserver : TObject); 168 // Detach an observer 169 Procedure FPODetachObserver(AObserver : TObject); 170 // Notify all observers of a change. 171 Procedure FPONotifyObservers(ASender : TObject; AOperation : TFPObservedOperation; Data : Pointer); 172 end; 173 174 { IFPObserver } 175 176 IFPObserver = Interface [SGUIDObserver] 177 // Called by observed when observers are notified. 178 Procedure FPOObservedChanged(ASender : TObject; Operation : TFPObservedOperation; Data : Pointer); 179 end; 180{$INTERFACES COM} 181 182 EObserver = Class(Exception); 183 184{ Forward class declarations } 185 186 TStream = class; 187 TFiler = class; 188 TReader = class; 189 TWriter = class; 190 TComponent = class; 191 192{ TFPList class } 193 194 PPointerList = ^TPointerList; 195 TPointerList = array[0..MaxListSize - 1] of Pointer; 196 TListSortCompare = function (Item1, Item2: Pointer): Integer; 197 TListCallback = Types.TListCallback; 198 TListStaticCallback = Types.TListStaticCallback; 199 200 201{$IFNDEF FPC_TESTGENERICS} 202 203 TListAssignOp = (laCopy, laAnd, laOr, laXor, laSrcUnique, laDestUnique); 204 TFPList = class; 205 206 TFPListEnumerator = class 207 private 208 FList: TFPList; 209 FPosition: Integer; 210 public 211 constructor Create(AList: TFPList); 212 function GetCurrent: Pointer; 213 function MoveNext: Boolean; 214 property Current: Pointer read GetCurrent; 215 end; 216 217 TFPList = class(TObject) 218 private 219 FList: PPointerList; 220 FCount: Integer; 221 FCapacity: Integer; 222 procedure CopyMove (aList : TFPList); 223 procedure MergeMove (aList : TFPList); 224 procedure DoCopy(ListA, ListB : TFPList); 225 procedure DoSrcUnique(ListA, ListB : TFPList); 226 procedure DoAnd(ListA, ListB : TFPList); 227 procedure DoDestUnique(ListA, ListB : TFPList); 228 procedure DoOr(ListA, ListB : TFPList); 229 procedure DoXOr(ListA, ListB : TFPList); 230 protected 231 function Get(Index: Integer): Pointer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 232 procedure Put(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 233 procedure SetCapacity(NewCapacity: Integer); 234 procedure SetCount(NewCount: Integer); 235 Procedure RaiseIndexError(Index: Integer); deprecated; 236 Procedure CheckIndex(AIndex : Integer); {$ifdef CLASSESINLINE} inline;{$ENDIF} 237 public 238 Type 239 TDirection = (FromBeginning, FromEnd); 240 destructor Destroy; override; 241 Procedure AddList(AList : TFPList); 242 function Add(Item: Pointer): Integer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 243 procedure Clear; 244 procedure Delete(Index: Integer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 245 class procedure Error(const Msg: string; Data: PtrInt); 246 procedure Exchange(Index1, Index2: Integer); 247 function Expand: TFPList; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 248 function Extract(Item: Pointer): Pointer; 249 function First: Pointer; 250 function GetEnumerator: TFPListEnumerator; 251 function IndexOf(Item: Pointer): Integer; 252 function IndexOfItem(Item: Pointer; Direction: TDirection): Integer; 253 procedure Insert(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 254 function Last: Pointer; 255 procedure Move(CurIndex, NewIndex: Integer); 256 procedure Assign (ListA: TFPList; AOperator: TListAssignOp=laCopy; ListB: TFPList=nil); 257 function Remove(Item: Pointer): Integer; 258 procedure Pack; 259 procedure Sort(Compare: TListSortCompare); 260 procedure ForEachCall(proc2call:TListCallback;arg:pointer); 261 procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer); 262 property Capacity: Integer read FCapacity write SetCapacity; 263 property Count: Integer read FCount write SetCount; 264 property Items[Index: Integer]: Pointer read Get write Put; default; 265 property List: PPointerList read FList; 266 end; 267 268{$else} 269 270 TFPPtrList = specialize TFPGList<Pointer>; 271 272 TFPList = class(TFPPtrList) 273 public 274 procedure Assign(Source: TFPList); 275 procedure Sort(Compare: TListSortCompare); 276 procedure ForEachCall(Proc2call: TListCallback; Arg: Pointer); 277 procedure ForEachCall(Proc2call: TListStaticCallback; Arg: Pointer); 278 end; 279 280{$endif} 281 282{ TList class} 283 284 TListNotification = (lnAdded, lnExtracted, lnDeleted); 285 TList = class; 286 287 TListEnumerator = class 288 private 289 FList: TList; 290 FPosition: Integer; 291 public 292 constructor Create(AList: TList); 293 function GetCurrent: Pointer; 294 function MoveNext: Boolean; 295 property Current: Pointer read GetCurrent; 296 end; 297 298 TList = class(TObject,IFPObserved) 299 private 300 FList: TFPList; 301 FObservers : TFPList; 302 procedure CopyMove (aList : TList); 303 procedure MergeMove (aList : TList); 304 procedure DoCopy(ListA, ListB : TList); 305 procedure DoSrcUnique(ListA, ListB : TList); 306 procedure DoAnd(ListA, ListB : TList); 307 procedure DoDestUnique(ListA, ListB : TList); 308 procedure DoOr(ListA, ListB : TList); 309 procedure DoXOr(ListA, ListB : TList); 310 protected 311 function Get(Index: Integer): Pointer; 312 procedure Grow; virtual; 313 procedure Put(Index: Integer; Item: Pointer); 314 procedure Notify(Ptr: Pointer; Action: TListNotification); virtual; 315 procedure SetCapacity(NewCapacity: Integer); 316 function GetCapacity: integer; 317 procedure SetCount(NewCount: Integer); 318 function GetCount: integer; 319 function GetList: PPointerList; 320 public 321 constructor Create; 322 destructor Destroy; override; 323 Procedure FPOAttachObserver(AObserver : TObject); 324 Procedure FPODetachObserver(AObserver : TObject); 325 Procedure FPONotifyObservers(ASender : TObject; AOperation : TFPObservedOperation; Data : Pointer); 326 Procedure AddList(AList : TList); 327 function Add(Item: Pointer): Integer; 328 procedure Clear; virtual; 329 procedure Delete(Index: Integer); 330 class procedure Error(const Msg: string; Data: PtrInt); virtual; 331 procedure Exchange(Index1, Index2: Integer); 332 function Expand: TList; 333 function Extract(item: Pointer): Pointer; 334 function First: Pointer; 335 function GetEnumerator: TListEnumerator; 336 function IndexOf(Item: Pointer): Integer; 337 procedure Insert(Index: Integer; Item: Pointer); 338 function Last: Pointer; 339 procedure Move(CurIndex, NewIndex: Integer); 340 procedure Assign (ListA: TList; AOperator: TListAssignOp=laCopy; ListB: TList=nil); 341 function Remove(Item: Pointer): Integer; 342 procedure Pack; 343 procedure Sort(Compare: TListSortCompare); 344 property Capacity: Integer read GetCapacity write SetCapacity; 345 property Count: Integer read GetCount write SetCount; 346 property Items[Index: Integer]: Pointer read Get write Put; default; 347 property List: PPointerList read GetList; 348 end; 349 350{ TThreadList class } 351 352 TThreadList = class 353 private 354 FList: TList; 355 FDuplicates: TDuplicates; 356 FLock: TRTLCriticalSection; 357 public 358 constructor Create; 359 destructor Destroy; override; 360 procedure Add(Item: Pointer); 361 procedure Clear; 362 function LockList: TList; 363 procedure Remove(Item: Pointer); 364 procedure UnlockList; 365 property Duplicates: TDuplicates read FDuplicates write FDuplicates; 366 end; 367 368{TBits Class} 369 370const 371 BITSHIFT = 5; 372 MASK = 31; {for longs that are 32-bit in size} 373 // to further increase, signed integer limits have to be researched. 374{$ifdef cpu16} 375 MaxBitFlags = $7FE0; 376{$else cpu16} 377 MaxBitFlags = $7FFFFFE0; 378{$endif cpu16} 379 MaxBitRec = MaxBitFlags Div (SizeOf(cardinal)*8); 380type 381 TBitArray = array[0..MaxBitRec - 1] of cardinal; 382 383 TBits = class(TObject) 384 private 385 { Private declarations } 386 FBits : ^TBitArray; 387 FSize : longint; { total longints currently allocated } 388 FBSize: longint; {total bits currently allocated} 389 findIndex : longint; 390 findState : boolean; 391 392 { functions and properties to match TBits class } 393 procedure SetBit(bit : longint; value : Boolean); 394 procedure SetSize(value : longint); 395 Protected 396 procedure CheckBitIndex (Bit : longint;CurrentSize : Boolean); 397 public 398 { Public declarations } 399 constructor Create(TheSize : longint = 0); virtual; 400 destructor Destroy; override; 401 function GetFSize : longint; 402 procedure SetOn(Bit : longint); 403 procedure Clear(Bit : longint); 404 procedure Clearall; 405 procedure CopyBits(BitSet : TBits); 406 procedure AndBits(BitSet : TBits); 407 procedure OrBits(BitSet : TBits); 408 procedure XorBits(BitSet : TBits); 409 procedure NotBits(BitSet : TBits); 410 function Get(Bit : longint) : boolean; 411 procedure Grow(NBit : longint); 412 function Equals(Obj : TObject): Boolean; override; overload; 413 function Equals(BitSet : TBits) : Boolean; overload; 414 procedure SetIndex(Index : longint); 415 function FindFirstBit(State : boolean) : longint; 416 function FindNextBit : longint; 417 function FindPrevBit : longint; 418 419 { functions and properties to match TBits class } 420 function OpenBit: longint; 421 property Bits[Bit: longint]: Boolean read get write SetBit; default; 422 property Size: longint read FBSize write setSize; 423 end; 424 425{ TPersistent abstract class } 426 427{$M+} 428 429 TPersistent = class(TObject,IFPObserved) 430 private 431 FObservers : TFPList; 432 procedure AssignError(Source: TPersistent); 433 protected 434 procedure AssignTo(Dest: TPersistent); virtual; 435 procedure DefineProperties(Filer: TFiler); virtual; 436 function GetOwner: TPersistent; dynamic; 437 public 438 Destructor Destroy; override; 439 procedure Assign(Source: TPersistent); virtual; 440 Procedure FPOAttachObserver(AObserver : TObject); 441 Procedure FPODetachObserver(AObserver : TObject); 442 Procedure FPONotifyObservers(ASender : TObject; AOperation : TFPObservedOperation; Data : Pointer); 443 function GetNamePath: string; virtual; {dynamic;} 444 end; 445 446{$M-} 447 448{ TPersistent class reference type } 449 450 TPersistentClass = class of TPersistent; 451 452{ TInterfaced Persistent } 453 454 TInterfacedPersistent = class(TPersistent, IInterface) 455 private 456 FOwnerInterface: IInterface; 457 protected 458 { IInterface } 459 function _AddRef: Longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 460 function _Release: Longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 461 public 462 function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 463 procedure AfterConstruction; override; 464 end; 465 466{ TRecall class } 467 468 TRecall = class(TObject) 469 private 470 FStorage, FReference: TPersistent; 471 public 472 constructor Create(AStorage, AReference: TPersistent); 473 destructor Destroy; override; 474 procedure Store; 475 procedure Forget; 476 property Reference: TPersistent read FReference; 477 end; 478 479{ TCollection class } 480 481 TCollection = class; 482 483 TCollectionItem = class(TPersistent) 484 private 485 FCollection: TCollection; 486 FID: Integer; 487 FUpdateCount: Integer; 488 function GetIndex: Integer; 489 protected 490 procedure SetCollection(Value: TCollection);virtual; 491 procedure Changed(AllItems: Boolean); 492 function GetOwner: TPersistent; override; 493 function GetDisplayName: string; virtual; 494 procedure SetIndex(Value: Integer); virtual; 495 procedure SetDisplayName(const Value: string); virtual; 496 property UpdateCount: Integer read FUpdateCount; 497 public 498 constructor Create(ACollection: TCollection); virtual; 499 destructor Destroy; override; 500 function GetNamePath: string; override; 501 property Collection: TCollection read FCollection write SetCollection; 502 property ID: Integer read FID; 503 property Index: Integer read GetIndex write SetIndex; 504 property DisplayName: string read GetDisplayName write SetDisplayName; 505 end; 506 507 TCollectionEnumerator = class 508 private 509 FCollection: TCollection; 510 FPosition: Integer; 511 public 512 constructor Create(ACollection: TCollection); 513 function GetCurrent: TCollectionItem; 514 function MoveNext: Boolean; 515 property Current: TCollectionItem read GetCurrent; 516 end; 517 518 TCollectionItemClass = class of TCollectionItem; 519 TCollectionNotification = (cnAdded, cnExtracting, cnDeleting); 520 TCollectionSortCompare = function (Item1, Item2: TCollectionItem): Integer; 521 522 TCollection = class(TPersistent) 523 private 524 FItemClass: TCollectionItemClass; 525 FItems: TFpList; 526 FUpdateCount: Integer; 527 FNextID: Integer; 528 FPropName: string; 529 function GetCount: Integer; 530 function GetPropName: string; 531 procedure InsertItem(Item: TCollectionItem); 532 procedure RemoveItem(Item: TCollectionItem); 533 procedure DoClear; 534 protected 535 { Design-time editor support } 536 function GetAttrCount: Integer; dynamic; 537 function GetAttr(Index: Integer): string; dynamic; 538 function GetItemAttr(Index, ItemIndex: Integer): string; dynamic; 539 procedure Changed; 540 function GetItem(Index: Integer): TCollectionItem; 541 procedure SetItem(Index: Integer; Value: TCollectionItem); 542 procedure SetItemName(Item: TCollectionItem); virtual; 543 procedure SetPropName; virtual; 544 procedure Update(Item: TCollectionItem); virtual; 545 procedure Notify(Item: TCollectionItem;Action: TCollectionNotification); virtual; 546 property PropName: string read GetPropName write FPropName; 547 property UpdateCount: Integer read FUpdateCount; 548 public 549 constructor Create(AItemClass: TCollectionItemClass); 550 destructor Destroy; override; 551 function Owner: TPersistent; 552 function Add: TCollectionItem; 553 procedure Assign(Source: TPersistent); override; 554 procedure BeginUpdate; virtual; 555 procedure Clear; 556 procedure EndUpdate; virtual; 557 procedure Delete(Index: Integer); 558 function GetEnumerator: TCollectionEnumerator; 559 function GetNamePath: string; override; 560 function Insert(Index: Integer): TCollectionItem; 561 function FindItemID(ID: Integer): TCollectionItem; 562 procedure Exchange(Const Index1, index2: integer); 563 procedure Move(Const Index1, index2: integer); 564 procedure Sort(Const Compare : TCollectionSortCompare); 565 property Count: Integer read GetCount; 566 property ItemClass: TCollectionItemClass read FItemClass; 567 property Items[Index: Integer]: TCollectionItem read GetItem write SetItem; 568 end; 569 570 TOwnedCollection = class(TCollection) 571 private 572 FOwner: TPersistent; 573 protected 574 Function GetOwner: TPersistent; override; 575 public 576 Constructor Create(AOwner: TPersistent;AItemClass: TCollectionItemClass); 577 end; 578 579 580 TStrings = class; 581 582{ IStringsAdapter interface } 583 584 { Maintains link between TStrings and IStrings implementations } 585 IStringsAdapter = interface ['{739C2F34-52EC-11D0-9EA6-0020AF3D82DA}'] 586 procedure ReferenceStrings(S: TStrings); 587 procedure ReleaseStrings; 588 end; 589 590{ TStringsEnumerator class } 591 592 TStringsEnumerator = class 593 private 594 FStrings: TStrings; 595 FPosition: Integer; 596 public 597 constructor Create(AStrings: TStrings); 598 function GetCurrent: String; 599 function MoveNext: Boolean; 600 property Current: String read GetCurrent; 601 end; 602 603{ TStrings class } 604 TStringsFilterMethod = function(const s: string): boolean of object; 605 TStringsReduceMethod = function(const s1, s2: string): string of object; 606 TStringsMapMethod = function(const s: string): string of object; 607 TStringsForEachMethodExObj = procedure(const CurrentValue: string; const index: integer; Obj : TObject) of object; 608 TStringsForEachMethodEx = procedure(const CurrentValue: string; const index: integer) of object; 609 TStringsForEachMethod = procedure(const CurrentValue: string) of object; 610 TMissingNameValueSeparatorAction = (mnvaValue,mnvaName,mnvaEmpty,mnvaError); 611 TMissingNameValueSeparatorActions = set of TMissingNameValueSeparatorAction; 612 TStringsOption = (soStrictDelimiter,soWriteBOM,soTrailingLineBreak,soUseLocale,soPreserveBOM); 613 TStringsOptions = set of TStringsOption; 614 615 TStrings = class(TPersistent) 616 private 617 FDefaultEncoding: TEncoding; 618 FEncoding: TEncoding; 619 FMissingNameValueSeparatorAction: TMissingNameValueSeparatorAction; 620 FSpecialCharsInited : boolean; 621 FAlwaysQuote: Boolean; 622 FQuoteChar : Char; 623 FDelimiter : Char; 624 FNameValueSeparator : Char; 625 FUpdateCount: Integer; 626 FAdapter: IStringsAdapter; 627 FLBS : TTextLineBreakStyle; 628 FOptions : TStringsOptions; 629 FLineBreak : String; 630 function GetCommaText: string; 631 function GetLineBreakCharLBS: string; 632 function GetMissingNameValueSeparatorAction: TMissingNameValueSeparatorAction; 633 function GetName(Index: Integer): string; 634 function GetStrictDelimiter: Boolean; 635 function GetTrailingLineBreak: Boolean; 636 function GetUseLocale: Boolean; 637 function GetValue(const Name: string): string; 638 function GetWriteBOM: Boolean; 639 Function GetLBS : TTextLineBreakStyle; 640 procedure SetDefaultEncoding(const ADefaultEncoding: TEncoding); 641 procedure SetEncoding(const AEncoding: TEncoding); 642 Procedure SetLBS (AValue : TTextLineBreakStyle); 643 procedure ReadData(Reader: TReader); 644 procedure SetCommaText(const Value: string); 645 procedure SetMissingNameValueSeparatorAction(AValue: TMissingNameValueSeparatorAction); 646 procedure SetStringsAdapter(const Value: IStringsAdapter); 647 procedure SetStrictDelimiter(AValue: Boolean); 648 procedure SetTrailingLineBreak(AValue: Boolean); 649 procedure SetUseLocale(AValue: Boolean); 650 procedure SetWriteBOM(AValue: Boolean); 651 procedure SetValue(const Name, Value: string); 652 procedure SetDelimiter(c:Char); 653 procedure SetQuoteChar(c:Char); 654 procedure SetNameValueSeparator(c:Char); 655 procedure WriteData(Writer: TWriter); 656 procedure DoSetTextStr(const Value: string; DoClear : Boolean); 657 Function GetDelimiter : Char; 658 Function GetNameValueSeparator : Char; 659 Function GetQuoteChar: Char; 660 Function GetLineBreak : String; 661 procedure SetLineBreak(const S : String); 662 Function GetSkipLastLineBreak : Boolean; 663 procedure SetSkipLastLineBreak(const AValue : Boolean); 664 Procedure DoSetDelimitedText(const AValue: string; DoClear,aStrictDelimiter : Boolean; aQuoteChar,aDelimiter : Char); 665 protected 666 function CompareStrings(const s1,s2 : string) : Integer; virtual; 667 procedure DefineProperties(Filer: TFiler); override; 668 procedure Error(const Msg: string; Data: Integer); 669 procedure Error(const Msg: pstring; Data: Integer); 670 function Get(Index: Integer): string; virtual; abstract; 671 function GetCapacity: Integer; virtual; 672 function GetCount: Integer; virtual; abstract; 673 function GetObject(Index: Integer): TObject; virtual; 674 function GetTextStr: string; virtual; 675 procedure Put(Index: Integer; const S: string); virtual; 676 procedure PutObject(Index: Integer; AObject: TObject); virtual; 677 procedure SetCapacity(NewCapacity: Integer); virtual; 678 procedure SetTextStr(const Value: string); virtual; 679 procedure SetUpdateState(Updating: Boolean); virtual; 680 property UpdateCount: Integer read FUpdateCount; 681 Function DoCompareText(const s1,s2 : string) : PtrInt; virtual; 682 Function GetDelimitedText: string; 683 Procedure SetDelimitedText(Const AValue: string); 684 Function GetValueFromIndex(Index: Integer): string; 685 Procedure SetValueFromIndex(Index: Integer; const Value: string); 686 Procedure CheckSpecialChars; 687 Class Function GetNextLine (Const Value : String; Var S : String; Var P : SizeInt) : Boolean; 688 Function GetNextLinebreak (Const Value : String; Var S : String; Var P : SizeInt) : Boolean; 689 {$IF (SizeOf(Integer) < SizeOf(SizeInt)) } 690 class function GetNextLine(const Value: string; var S: string; var P: Integer) : Boolean; deprecated; 691 function GetNextLineBreak(const Value: string; var S: string; var P: Integer) : Boolean; deprecated; 692 {$IFEND} 693 public 694 constructor Create; 695 destructor Destroy; override; 696 function ToObjectArray(aStart,aEnd : Integer) : TObjectDynArray; overload; 697 function ToObjectArray: TObjectDynArray; overload; 698 function ToStringArray(aStart,aEnd : Integer) : TStringDynArray; overload; 699 function ToStringArray: TStringDynArray; overload; 700 function Add(const S: string): Integer; virtual; overload; 701 function AddObject(const S: string; AObject: TObject): Integer; virtual; overload; 702 function Add(const Fmt : string; const Args : Array of const): Integer; overload; 703 function AddObject(const Fmt: string; Args : Array of const; AObject: TObject): Integer; overload; 704 function AddPair(const AName, AValue: string): TStrings; overload; {$IFDEF CLASSESINLINE}inline;{$ENDIF} 705 function AddPair(const AName, AValue: string; AObject: TObject): TStrings; overload; 706 procedure AddStrings(TheStrings: TStrings); overload; virtual; 707 procedure AddStrings(TheStrings: TStrings; ClearFirst : Boolean); overload; 708 procedure AddStrings(const TheStrings: array of string); overload; virtual; 709 procedure AddStrings(const TheStrings: array of string; ClearFirst : Boolean); overload; 710 procedure SetStrings(TheStrings: TStrings); overload; virtual; 711 procedure SetStrings(TheStrings: array of string); overload; virtual; 712 Procedure AddText(Const S : String); virtual; 713 procedure AddCommaText(const S: String); 714 procedure AddDelimitedText(const S: String; ADelimiter: char; AStrictDelimiter: Boolean); overload; 715 procedure AddDelimitedtext(const S: String); overload; 716 procedure Append(const S: string); 717 procedure Assign(Source: TPersistent); override; 718 procedure BeginUpdate; 719 procedure Clear; virtual; abstract; 720 procedure Delete(Index: Integer); virtual; abstract; 721 procedure EndUpdate; 722 function Equals(Obj: TObject): Boolean; override; overload; 723 function Equals(TheStrings: TStrings): Boolean; overload; 724 procedure Exchange(Index1, Index2: Integer); virtual; 725 function ExtractName(Const S:String):String; 726 Procedure Filter(aFilter: TStringsFilterMethod; aList : TStrings); 727 Function Filter(aFilter: TStringsFilterMethod) : TStrings; 728 Procedure Fill(const aValue : String; aStart,aEnd : Integer); 729 procedure ForEach(aCallback: TStringsForeachMethod); 730 procedure ForEach(aCallback: TStringsForeachMethodEx); 731 procedure ForEach(aCallback: TStringsForeachMethodExObj); 732 function GetEnumerator: TStringsEnumerator; 733 procedure GetNameValue(Index : Integer; Out AName,AValue : String); 734 function GetText: PChar; virtual; 735 function IndexOf(const S: string): Integer; virtual; 736 function IndexOf(const S: string; aStart : Integer): Integer; virtual; 737 function IndexOfName(const Name: string): Integer; virtual; 738 function IndexOfObject(AObject: TObject): Integer; virtual; 739 procedure Insert(Index: Integer; const S: string); virtual; abstract; 740 procedure InsertObject(Index: Integer; const S: string; AObject: TObject); 741 function LastIndexOf(const S: string; aStart : Integer): Integer; virtual; 742 function LastIndexOf(const S: string): Integer; 743 procedure LoadFromFile(const FileName: string); overload; virtual; 744 procedure LoadFromFile(const FileName: string; IgnoreEncoding : Boolean); 745 procedure LoadFromFile(const FileName: string; AEncoding: TEncoding); overload; virtual; 746 procedure LoadFromStream(Stream: TStream); overload; virtual; 747 procedure LoadFromStream(Stream: TStream; IgnoreEncoding : Boolean); overload; 748 procedure LoadFromStream(Stream: TStream; AEncoding: TEncoding); overload; virtual; 749 Procedure Map(aMap: TStringsMapMethod; aList : TStrings); 750 Function Map(aMap: TStringsMapMethod) : TStrings; 751 procedure Move(CurIndex, NewIndex: Integer); virtual; 752 Function Pop : String; 753 function Reduce(aReduceMethod: TStringsReduceMethod; const startingValue: string): string; 754 Function Reverse : TStrings; 755 Procedure Reverse(aList : TStrings); 756 procedure SaveToFile(const FileName: string); overload; virtual; 757 procedure SaveToFile(const FileName: string; IgnoreEncoding : Boolean); overload; 758 procedure SaveToFile(const FileName: string; AEncoding: TEncoding); overload; virtual; 759 procedure SaveToStream(Stream: TStream); overload; virtual; 760 procedure SaveToStream(Stream: TStream; IgnoreEncoding : Boolean); overload; 761 procedure SaveToStream(Stream: TStream; AEncoding: TEncoding); overload; virtual; 762 function Shift : String; 763 Procedure Slice(fromIndex: integer; aList : TStrings); 764 Function Slice(fromIndex: integer) : TStrings; 765 procedure SetText(TheText: PChar); virtual; 766 property AlwaysQuote: Boolean read FAlwaysQuote write FAlwaysQuote; 767 property Capacity: Integer read GetCapacity write SetCapacity; 768 property CommaText: string read GetCommaText write SetCommaText; 769 property Count: Integer read GetCount; 770 property DefaultEncoding: TEncoding read FDefaultEncoding write SetDefaultEncoding; 771 property DelimitedText: string read GetDelimitedText write SetDelimitedText; 772 property Delimiter: Char read GetDelimiter write SetDelimiter; 773 property Encoding: TEncoding read FEncoding; 774 property LineBreak : string Read GetLineBreak write SetLineBreak; 775 Property MissingNameValueSeparatorAction : TMissingNameValueSeparatorAction Read GetMissingNameValueSeparatorAction Write SetMissingNameValueSeparatorAction; 776 property Names[Index: Integer]: string read GetName; 777 Property NameValueSeparator : Char Read GetNameValueSeparator Write SetNameValueSeparator; 778 property Objects[Index: Integer]: TObject read GetObject write PutObject; 779 property Options: TStringsOptions read FOptions write FOptions; 780 property QuoteChar: Char read GetQuoteChar write SetQuoteChar; 781 Property SkipLastLineBreak : Boolean Read GetSkipLastLineBreak Write SetSkipLastLineBreak; 782 // Same as SkipLastLineBreak but for Delphi compatibility. Note it has opposite meaning. 783 Property TrailingLineBreak : Boolean Read GetTrailingLineBreak Write SetTrailingLineBreak; 784 Property StrictDelimiter : Boolean Read GetStrictDelimiter Write SetStrictDelimiter; 785 property Strings[Index: Integer]: string read Get write Put; default; 786 property StringsAdapter: IStringsAdapter read FAdapter write SetStringsAdapter; 787 property Text: string read GetTextStr write SetTextStr; 788 Property TextLineBreakStyle : TTextLineBreakStyle Read GetLBS Write SetLBS; 789 Property UseLocale : Boolean Read GetUseLocale Write SetUseLocale; 790 property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex; 791 property Values[const Name: string]: string read GetValue write SetValue; 792 property WriteBOM: Boolean read GetWriteBOM write SetWriteBOM; 793 end; 794 TStringsClass = Class of TStrings; 795 796{ TStringList class } 797 798 TStringList = class; 799 800 TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer; 801 802{$IFNDEF FPC_TESTGENERICS} 803 804 PStringItem = ^TStringItem; 805 TStringItem = record 806 FString: string; 807 FObject: TObject; 808 end; 809 810 PStringItemList = ^TStringItemList; 811 TStringItemList = array[0..MaxListSize] of TStringItem; 812 813 TStringsSortStyle = (sslNone,sslUser,sslAuto); 814 TStringsSortStyles = Set of TStringsSortStyle; 815 816 TStringList = class(TStrings) 817 private 818 FList: PStringItemList; 819 FCount: Integer; 820 FCapacity: Integer; 821 FOnChange: TNotifyEvent; 822 FOnChanging: TNotifyEvent; 823 FDuplicates: TDuplicates; 824 FCaseSensitive : Boolean; 825 FForceSort : Boolean; 826 FOwnsObjects : Boolean; 827 FSortStyle: TStringsSortStyle; 828 procedure ExchangeItemsInt(Index1, Index2: Integer); inline; 829 function GetSorted: Boolean; 830 procedure Grow; 831 procedure InternalClear(FromIndex : Integer = 0; ClearOnly : Boolean = False); 832 procedure QuickSort(L, R: Integer; CompareFn: TStringListSortCompare); 833 procedure SetSorted(Value: Boolean); 834 procedure SetCaseSensitive(b : boolean); 835 procedure SetSortStyle(AValue: TStringsSortStyle); 836 protected 837 Procedure CheckIndex(AIndex : Integer); inline; 838 procedure ExchangeItems(Index1, Index2: Integer); virtual; 839 procedure Changed; virtual; 840 procedure Changing; virtual; 841 function Get(Index: Integer): string; override; 842 function GetCapacity: Integer; override; 843 function GetCount: Integer; override; 844 function GetObject(Index: Integer): TObject; override; 845 procedure Put(Index: Integer; const S: string); override; 846 procedure PutObject(Index: Integer; AObject: TObject); override; 847 procedure SetCapacity(NewCapacity: Integer); override; 848 procedure SetUpdateState(Updating: Boolean); override; 849 procedure InsertItem(Index: Integer; const S: string); virtual; 850 procedure InsertItem(Index: Integer; const S: string; O: TObject); virtual; 851 Function DoCompareText(const s1,s2 : string) : PtrInt; override; 852 853 public 854 destructor Destroy; override; 855 function Add(const S: string): Integer; override; 856 procedure Clear; override; 857 procedure Delete(Index: Integer); override; 858 procedure Exchange(Index1, Index2: Integer); override; 859 function Find(const S: string; Out Index: Integer): Boolean; virtual; 860 function IndexOf(const S: string): Integer; override; 861 procedure Insert(Index: Integer; const S: string); override; 862 procedure Sort; virtual; 863 procedure CustomSort(CompareFn: TStringListSortCompare); virtual; 864 property Duplicates: TDuplicates read FDuplicates write FDuplicates; 865 property Sorted: Boolean read GetSorted write SetSorted; 866 property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; 867 property OnChange: TNotifyEvent read FOnChange write FOnChange; 868 property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; 869 property OwnsObjects : boolean read FOwnsObjects write FOwnsObjects; 870 Property SortStyle : TStringsSortStyle Read FSortStyle Write SetSortStyle; 871 end; 872 873{$else} 874 875 TFPStrObjMap = specialize TFPGMap<string, TObject>; 876 877 TStringListTextCompare = function(const s1, s2: string): PtrInt of object; 878 879 TStringList = class(TStrings) 880 private 881 FMap: TFPStrObjMap; 882 FCaseSensitive: Boolean; 883 FOnChange: TNotifyEvent; 884 FOnChanging: TNotifyEvent; 885 FOnCompareText: TStringListTextCompare; 886 FOwnsObjects : Boolean; 887 procedure SetCaseSensitive(NewSensitive: Boolean); 888 protected 889 procedure Changed; virtual; 890 procedure Changing; virtual; 891 function DefaultCompareText(const s1, s2: string): PtrInt; 892 function DoCompareText(const s1, s2: string): PtrInt; override; 893 function Get(Index: Integer): string; override; 894 function GetCapacity: Integer; override; 895 function GetDuplicates: TDuplicates; 896 function GetCount: Integer; override; 897 function GetObject(Index: Integer): TObject; override; 898 function GetSorted: Boolean; {$ifdef CLASSESINLINE} inline; {$endif} 899 function MapPtrCompare(Key1, Key2: Pointer): Integer; 900 procedure Put(Index: Integer; const S: string); override; 901 procedure PutObject(Index: Integer; AObject: TObject); override; 902 procedure QuickSort(L, R: Integer; CompareFn: TStringListSortCompare); 903 procedure SetCapacity(NewCapacity: Integer); override; 904 procedure SetDuplicates(NewDuplicates: TDuplicates); 905 procedure SetSorted(NewSorted: Boolean); {$ifdef CLASSESINLINE} inline; {$endif} 906 procedure SetUpdateState(Updating: Boolean); override; 907 public 908 constructor Create; 909 destructor Destroy; override; 910 function Add(const S: string): Integer; override; 911 procedure Clear; override; 912 procedure Delete(Index: Integer); override; 913 procedure Exchange(Index1, Index2: Integer); override; 914 function Find(const S: string; var Index: Integer): Boolean; virtual; 915 function IndexOf(const S: string): Integer; override; 916 procedure Insert(Index: Integer; const S: string); override; 917 procedure Sort; virtual; 918 procedure CustomSort(CompareFn: TStringListSortCompare); 919 property Duplicates: TDuplicates read GetDuplicates write SetDuplicates; 920 property Sorted: Boolean read GetSorted write SetSorted; 921 property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; 922 property OnChange: TNotifyEvent read FOnChange write FOnChange; 923 property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; 924 property OnCompareText: TStringListTextCompare read FOnCompareText write FOnCompareText; 925 property OwnsObjects : boolean read FOwnsObjects write FOwnsObjects; 926 end; 927 928{$endif} 929 930 931{ TStream abstract class } 932 933 TStream = class(TObject) 934 private 935 protected 936 procedure InvalidSeek; virtual; 937 procedure Discard(const Count: Int64); 938 procedure DiscardLarge(Count: int64; const MaxBufferSize: Longint); 939 procedure FakeSeekForward(Offset: Int64; const Origin: TSeekOrigin; const Pos: Int64); 940 function GetPosition: Int64; virtual; 941 procedure SetPosition(const Pos: Int64); virtual; 942 function GetSize: Int64; virtual; 943 procedure SetSize64(const NewSize: Int64); virtual; 944 procedure SetSize(NewSize: Longint); virtual;overload; 945 procedure SetSize(const NewSize: Int64); virtual;overload; 946 procedure ReadNotImplemented; 947 procedure WriteNotImplemented; 948 public 949 function Read(var Buffer; Count: Longint): Longint; virtual; overload; 950 function Write(const Buffer; Count: Longint): Longint; virtual; overload; 951 function Seek(Offset: Longint; Origin: Word): Longint; virtual; overload; 952 function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; virtual; overload; 953 procedure ReadBuffer(var Buffer; Count: Longint); 954 procedure WriteBuffer(const Buffer; Count: Longint); 955 function CopyFrom(Source: TStream; Count: Int64): Int64; 956 function ReadComponent(Instance: TComponent): TComponent; 957 function ReadComponentRes(Instance: TComponent): TComponent; 958 procedure WriteComponent(Instance: TComponent); 959 procedure WriteComponentRes(const ResName: string; Instance: TComponent); 960 procedure WriteDescendent(Instance, Ancestor: TComponent); 961 procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent); 962 procedure WriteResourceHeader(const ResName: string; {!!!:out} var FixupInfo: Longint); 963 procedure FixupResourceHeader(FixupInfo: Longint); 964 procedure ReadResHeader; 965 function ReadByte : Byte; 966 function ReadWord : Word; 967 function ReadDWord : Cardinal; 968 function ReadQWord : QWord; 969 function ReadAnsiString : String; 970 procedure WriteByte(b : Byte); 971 procedure WriteWord(w : Word); 972 procedure WriteDWord(d : Cardinal); 973 procedure WriteQWord(q : QWord); 974 Procedure WriteAnsiString (const S : String); virtual; 975 property Position: Int64 read GetPosition write SetPosition; 976 property Size: Int64 read GetSize write SetSize64; 977 end; 978 979 TProxyStream = class(TStream) 980 private 981 FStream: IStream; 982 protected 983 function GetIStream: IStream; 984 public 985 constructor Create(const Stream: IStream); 986 function Read(var Buffer; Count: Longint): Longint; override; 987 function Write(const Buffer; Count: Longint): Longint; override; 988 function Seek(const Offset: int64; Origin: TSeekOrigin): int64; override; 989 procedure Check(err:integer); virtual; 990 end; 991 992 { TOwnerStream } 993 TOwnerStream = Class(TStream) 994 Protected 995 FOwner : Boolean; 996 FSource : TStream; 997 Public 998 Constructor Create(ASource : TStream); 999 Destructor Destroy; override; 1000 Property Source : TStream Read FSource; 1001 Property SourceOwner : Boolean Read Fowner Write FOwner; 1002 end; 1003 1004 1005 IStreamPersist = interface ['{B8CD12A3-267A-11D4-83DA-00C04F60B2DD}'] 1006 procedure LoadFromStream(Stream: TStream); 1007 procedure SaveToStream(Stream: TStream); 1008 end; 1009 1010{ THandleStream class } 1011 1012 THandleStream = class(TStream) 1013 private 1014 FHandle: THandle; 1015 protected 1016 procedure SetSize(NewSize: Longint); override; 1017 procedure SetSize(const NewSize: Int64); override; 1018 public 1019 constructor Create(AHandle: THandle); 1020 function Read(var Buffer; Count: Longint): Longint; override; 1021 function Write(const Buffer; Count: Longint): Longint; override; 1022 function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; 1023 property Handle: THandle read FHandle; 1024 end; 1025 1026{ TFileStream class } 1027 1028 TFileStream = class(THandleStream) 1029 Private 1030 FFileName : String; 1031 public 1032 constructor Create(const AFileName: string; Mode: Word); 1033 constructor Create(const AFileName: string; Mode: Word; Rights: Cardinal); 1034 destructor Destroy; override; 1035 property FileName : String Read FFilename; 1036 end; 1037 1038{ TCustomMemoryStream abstract class } 1039 1040 TCustomMemoryStream = class(TStream) 1041 private 1042 FMemory: Pointer; 1043 FSize, FPosition: PtrInt; 1044 protected 1045 Function GetSize : Int64; Override; 1046 function GetPosition: Int64; Override; 1047 procedure SetPointer(Ptr: Pointer; ASize: PtrInt); 1048 public 1049 function Read(var Buffer; Count: LongInt): LongInt; override; 1050 function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; 1051 procedure SaveToStream(Stream: TStream); 1052 procedure SaveToFile(const FileName: string); 1053 property Memory: Pointer read FMemory; 1054 end; 1055 1056{ TMemoryStream } 1057 1058 TMemoryStream = class(TCustomMemoryStream) 1059 private 1060 FCapacity: PtrInt; 1061 procedure SetCapacity(NewCapacity: PtrInt); 1062 protected 1063 function Realloc(var NewCapacity: PtrInt): Pointer; virtual; 1064 property Capacity: PtrInt read FCapacity write SetCapacity; 1065 public 1066 destructor Destroy; override; 1067 procedure Clear; 1068 procedure LoadFromStream(Stream: TStream); 1069 procedure LoadFromFile(const FileName: string); 1070 procedure SetSize({$ifdef CPU64}const NewSize: Int64{$else}NewSize: LongInt{$endif}); override; 1071 function Write(const Buffer; Count: LongInt): LongInt; override; 1072 end; 1073 1074{ TBytesStream } 1075 1076 TBytesStream = class(TMemoryStream) 1077 private 1078 FBytes: TBytes; 1079 protected 1080 function Realloc(var NewCapacity: PtrInt): Pointer; override; 1081 public 1082 constructor Create(const ABytes: TBytes); virtual; overload; 1083 property Bytes: TBytes read FBytes; 1084 end; 1085 1086{ TStringStream } 1087 1088 TStringStream = class(TBytesStream) 1089 private 1090 FEncoding: TEncoding; 1091 FOwnsEncoding : Boolean; 1092 function GetDataString: string; 1093 function GetUnicodeDataString: UnicodeString; 1094 protected 1095 public 1096 constructor Create(const ABytes: TBytes); override; overload; 1097 constructor Create(const AString: string = ''); overload; 1098 constructor CreateRaw(const AString: RawByteString); overload; 1099 constructor Create(const AString: string; AEncoding: TEncoding; AOwnsEncoding: Boolean = True); overload; 1100 constructor Create(const AString: string; ACodePage: Integer); overload; 1101 // UnicodeString versions 1102 constructor Create(const AString: UnicodeString); overload; 1103 constructor Create(const AString: UnicodeString; AEncoding: TEncoding; AOwnsEncoding: Boolean = True); overload; 1104 constructor Create(const AString: UnicodeString; ACodePage: Integer); overload; 1105 Destructor Destroy; override; 1106 function ReadUnicodeString(Count: Longint): UnicodeString; 1107 procedure WriteUnicodeString(const AString: UnicodeString); 1108 function ReadAnsiString(Count: Longint): AnsiString; overload; 1109 procedure WriteAnsiString(const AString: AnsiString); override; 1110 function ReadString(Count: Longint): string; 1111 procedure WriteString(const AString: string); 1112 property DataString: string read GetDataString; 1113 Property UnicodeDataString : UnicodeString Read GetUnicodeDataString; 1114 Property OwnsEncoding : Boolean Read FOwnsEncoding; 1115 Property Encoding : TEncoding Read FEncoding; 1116 end; 1117 1118{ TRawByteStringStream } 1119 1120 TRawByteStringStream = Class(TBytesStream) 1121 public 1122 Constructor Create (const aData : RawByteString); overload; 1123 function DataString: RawByteString; 1124 1125 function ReadString(Count: Longint): RawByteString; 1126 procedure WriteString(const AString: RawByteString); 1127 end; 1128 1129{ TResourceStream } 1130 1131{$ifdef FPC_OS_UNICODE} 1132 TResourceStream = class(TCustomMemoryStream) 1133 private 1134 Res: TFPResourceHandle; 1135 Handle: TFPResourceHGLOBAL; 1136 procedure Initialize(Instance: TFPResourceHMODULE; Name, ResType: PWideChar; NameIsID: Boolean); 1137 public 1138 constructor Create(Instance: TFPResourceHMODULE; const ResName: WideString; ResType: PWideChar); 1139 constructor CreateFromID(Instance: TFPResourceHMODULE; ResID: Integer; ResType: PWideChar); 1140 destructor Destroy; override; 1141 end; 1142{$else} 1143 TResourceStream = class(TCustomMemoryStream) 1144 private 1145 Res: TFPResourceHandle; 1146 Handle: TFPResourceHGLOBAL; 1147 procedure Initialize(Instance: TFPResourceHMODULE; Name, ResType: PChar; NameIsID: Boolean); 1148 public 1149 constructor Create(Instance: TFPResourceHMODULE; const ResName: string; ResType: PChar); 1150 constructor CreateFromID(Instance: TFPResourceHMODULE; ResID: Integer; ResType: PChar); 1151 destructor Destroy; override; 1152 end; 1153{$endif FPC_OS_UNICODE} 1154 1155{ TStreamAdapter } 1156 1157 TStreamOwnership = (soReference, soOwned); 1158 1159{ Implements OLE IStream on TStream } 1160 TStreamAdapter = class(TInterfacedObject, IStream) 1161 private 1162 FStream : TStream; 1163 FOwnership : TStreamOwnership; 1164 m_bReverted: Boolean; 1165 public 1166 constructor Create(Stream: TStream; Ownership: TStreamOwnership = soReference); 1167 destructor Destroy; override; 1168 function Read(pv: Pointer; cb: DWORD; pcbRead: PDWORD): HResult; virtual; stdcall; 1169 function Write(pv: Pointer; cb: DWORD; pcbWritten: PDWORD): HResult; virtual; stdcall; 1170 function Seek(dlibMove: LargeInt; dwOrigin: DWORD; out libNewPosition: LargeUint): HResult; virtual; stdcall; 1171 function SetSize(libNewSize: LargeUint): HResult; virtual; stdcall; 1172 function CopyTo(stm: IStream; cb: LargeUint; out cbRead: LargeUint; out cbWritten: LargeUint): HResult; virtual; stdcall; 1173 function Commit(grfCommitFlags: DWORD): HResult; virtual; stdcall; 1174 function Revert: HResult; virtual; stdcall; 1175 function LockRegion(libOffset: LargeUint; cb: LargeUint; dwLockType: DWORD): HResult; virtual; stdcall; 1176 function UnlockRegion(libOffset: LargeUint; cb: LargeUint; dwLockType: DWORD): HResult; virtual; stdcall; 1177 function Stat(out statstg: TStatStg; grfStatFlag: DWORD): HResult; virtual; stdcall; 1178 function Clone(out stm: IStream): HResult; virtual; stdcall; 1179 property Stream: TStream read FStream; 1180 property StreamOwnership: TStreamOwnership read FOwnership write FOwnership; 1181 end; 1182 1183{ TFiler } 1184 1185 TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended, 1186 vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString, 1187 vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64, 1188 vaUTF8String, vaUString, vaQWord); 1189 1190 TFilerFlag = (ffInherited, ffChildPos, ffInline); 1191 TFilerFlags = set of TFilerFlag; 1192 1193 TReaderProc = procedure(Reader: TReader) of object; 1194 TWriterProc = procedure(Writer: TWriter) of object; 1195 TStreamProc = procedure(Stream: TStream) of object; 1196 1197 TFiler = class(TObject) 1198 private 1199 FRoot: TComponent; 1200 FLookupRoot: TComponent; 1201 FAncestor: TPersistent; 1202 FIgnoreChildren: Boolean; 1203 protected 1204 procedure SetRoot(ARoot: TComponent); virtual; 1205 public 1206 procedure DefineProperty(const Name: string; 1207 ReadData: TReaderProc; WriteData: TWriterProc; 1208 HasData: Boolean); virtual; abstract; 1209 procedure DefineBinaryProperty(const Name: string; 1210 ReadData, WriteData: TStreamProc; 1211 HasData: Boolean); virtual; abstract; 1212 Procedure FlushBuffer; virtual; abstract; 1213 property Root: TComponent read FRoot write SetRoot; 1214 property LookupRoot: TComponent read FLookupRoot; 1215 property Ancestor: TPersistent read FAncestor write FAncestor; 1216 property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren; 1217 end; 1218 1219 1220{ TComponent class reference type } 1221 1222 TComponentClass = class of TComponent; 1223 1224 1225{ TReader } 1226 1227 { TAbstractObjectReader } 1228 1229 TAbstractObjectReader = class 1230 public 1231 Procedure FlushBuffer; virtual; 1232 function NextValue: TValueType; virtual; abstract; 1233 function ReadValue: TValueType; virtual; abstract; 1234 procedure BeginRootComponent; virtual; abstract; 1235 procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer; 1236 var CompClassName, CompName: String); virtual; abstract; 1237 function BeginProperty: String; virtual; abstract; 1238 1239 //Please don't use read, better use ReadBinary whenever possible 1240 procedure Read(var Buf; Count: LongInt); virtual; abstract; 1241 { All ReadXXX methods are called _after_ the value type has been read! } 1242 procedure ReadBinary(const DestData: TMemoryStream); virtual; abstract; 1243{$ifndef FPUNONE} 1244 function ReadFloat: Extended; virtual; abstract; 1245 function ReadSingle: Single; virtual; abstract; 1246 function ReadDate: TDateTime; virtual; abstract; 1247{$endif} 1248 function ReadCurrency: Currency; virtual; abstract; 1249 function ReadIdent(ValueType: TValueType): String; virtual; abstract; 1250 function ReadInt8: ShortInt; virtual; abstract; 1251 function ReadInt16: SmallInt; virtual; abstract; 1252 function ReadInt32: LongInt; virtual; abstract; 1253 function ReadInt64: Int64; virtual; abstract; 1254 function ReadSet(EnumType: Pointer): Integer; virtual; abstract; 1255 procedure ReadSignature; virtual; abstract; 1256 function ReadStr: String; virtual; abstract; 1257 function ReadString(StringType: TValueType): String; virtual; abstract; 1258 function ReadWideString: WideString;virtual;abstract; 1259 function ReadUnicodeString: UnicodeString;virtual;abstract; 1260 procedure SkipComponent(SkipComponentInfos: Boolean); virtual; abstract; 1261 procedure SkipValue; virtual; abstract; 1262 end; 1263 1264 { TBinaryObjectReader } 1265 1266 TBinaryObjectReader = class(TAbstractObjectReader) 1267 protected 1268 FStream: TStream; 1269 FBuffer: Pointer; 1270 FBufSize: Integer; 1271 FBufPos: Integer; 1272 FBufEnd: Integer; 1273 1274 function ReadWord : word; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 1275 function ReadDWord : longword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 1276 function ReadQWord : qword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 1277{$ifndef FPUNONE} 1278 function ReadExtended : extended; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 1279{$endif} 1280 procedure SkipProperty; 1281 procedure SkipSetBody; 1282 public 1283 constructor Create(Stream: TStream; BufSize: Integer); 1284 destructor Destroy; override; 1285 function NextValue: TValueType; override; 1286 function ReadValue: TValueType; override; 1287 procedure BeginRootComponent; override; 1288 procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer; 1289 var CompClassName, CompName: String); override; 1290 function BeginProperty: String; override; 1291 1292 //Please don't use read, better use ReadBinary whenever possible 1293 procedure Read(var Buf; Count: LongInt); override; 1294 procedure ReadBinary(const DestData: TMemoryStream); override; 1295{$ifndef FPUNONE} 1296 function ReadFloat: Extended; override; 1297 function ReadSingle: Single; override; 1298 function ReadDate: TDateTime; override; 1299{$endif} 1300 function ReadCurrency: Currency; override; 1301 function ReadIdent(ValueType: TValueType): String; override; 1302 function ReadInt8: ShortInt; override; 1303 function ReadInt16: SmallInt; override; 1304 function ReadInt32: LongInt; override; 1305 function ReadInt64: Int64; override; 1306 function ReadSet(EnumType: Pointer): Integer; override; 1307 procedure ReadSignature; override; 1308 function ReadStr: String; override; 1309 function ReadString(StringType: TValueType): String; override; 1310 function ReadWideString: WideString;override; 1311 function ReadUnicodeString: UnicodeString;override; 1312 procedure SkipComponent(SkipComponentInfos: Boolean); override; 1313 procedure SkipValue; override; 1314 end; 1315 1316 1317 TFindMethodEvent = procedure(Reader: TReader; const MethodName: string; 1318 var Address: CodePointer; var Error: Boolean) of object; 1319 TSetMethodPropertyEvent = procedure(Reader: TReader; Instance: TPersistent; 1320 PropInfo: PPropInfo; const TheMethodName: string; 1321 var Handled: boolean) of object; 1322 TSetNameEvent = procedure(Reader: TReader; Component: TComponent; 1323 var Name: string) of object; 1324 TReferenceNameEvent = procedure(Reader: TReader; var Name: string) of object; 1325 TAncestorNotFoundEvent = procedure(Reader: TReader; const ComponentName: string; 1326 ComponentClass: TPersistentClass; var Component: TComponent) of object; 1327 TReadComponentsProc = procedure(Component: TComponent) of object; 1328 TReaderError = procedure(Reader: TReader; const Message: string; 1329 var Handled: Boolean) of object; 1330 TPropertyNotFoundEvent = procedure(Reader: TReader; Instance: TPersistent; 1331 var PropName: string; IsPath: boolean; var Handled, Skip: Boolean) of object; 1332 TFindComponentClassEvent = procedure(Reader: TReader; const ClassName: string; 1333 var ComponentClass: TComponentClass) of object; 1334 TCreateComponentEvent = procedure(Reader: TReader; 1335 ComponentClass: TComponentClass; var Component: TComponent) of object; 1336 1337 TReadWriteStringPropertyEvent = procedure(Sender:TObject; 1338 const Instance: TPersistent; PropInfo: PPropInfo; 1339 var Content:string) of object; 1340 1341 1342 { TReader } 1343 1344 TReader = class(TFiler) 1345 private 1346 FDriver: TAbstractObjectReader; 1347 FOwner: TComponent; 1348 FParent: TComponent; 1349 FFixups: TObject; 1350 FLoaded: TFpList; 1351 FLock: TRTLCriticalSection; 1352 FOnFindMethod: TFindMethodEvent; 1353 FOnSetMethodProperty: TSetMethodPropertyEvent; 1354 FOnSetName: TSetNameEvent; 1355 FOnReferenceName: TReferenceNameEvent; 1356 FOnAncestorNotFound: TAncestorNotFoundEvent; 1357 FOnError: TReaderError; 1358 FOnPropertyNotFound: TPropertyNotFoundEvent; 1359 FOnFindComponentClass: TFindComponentClassEvent; 1360 FOnCreateComponent: TCreateComponentEvent; 1361 FPropName: string; 1362 FCanHandleExcepts: Boolean; 1363 FOnReadStringProperty:TReadWriteStringPropertyEvent; 1364 procedure DoFixupReferences; 1365 function FindComponentClass(const AClassName: string): TComponentClass; 1366 procedure Lock; 1367 procedure Unlock; 1368 protected 1369 function Error(const Message: string): Boolean; virtual; 1370 function FindMethod(ARoot: TComponent; const AMethodName: string): CodePointer; virtual; 1371 procedure ReadProperty(AInstance: TPersistent); 1372 procedure ReadPropValue(Instance: TPersistent; PropInfo: Pointer); 1373 procedure PropertyError; 1374 procedure ReadData(Instance: TComponent); 1375 property PropName: string read FPropName; 1376 property CanHandleExceptions: Boolean read FCanHandleExcepts; 1377 function CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectReader; virtual; 1378 public 1379 constructor Create(Stream: TStream; BufSize: Integer); 1380 destructor Destroy; override; 1381 Procedure FlushBuffer; override; 1382 procedure BeginReferences; 1383 procedure CheckValue(Value: TValueType); 1384 procedure DefineProperty(const Name: string; 1385 AReadData: TReaderProc; WriteData: TWriterProc; 1386 HasData: Boolean); override; 1387 procedure DefineBinaryProperty(const Name: string; 1388 AReadData, WriteData: TStreamProc; 1389 HasData: Boolean); override; 1390 function EndOfList: Boolean; 1391 procedure EndReferences; 1392 procedure FixupReferences; 1393 function NextValue: TValueType; 1394 //Please don't use read, better use ReadBinary whenever possible 1395 //uuups, ReadBinary is protected .. 1396 procedure Read(var Buf; Count: LongInt); virtual; 1397 1398 function ReadBoolean: Boolean; 1399 function ReadChar: Char; 1400 function ReadWideChar: WideChar; 1401 function ReadUnicodeChar: UnicodeChar; 1402 procedure ReadCollection(Collection: TCollection); 1403 function ReadComponent(Component: TComponent): TComponent; 1404 procedure ReadComponents(AOwner, AParent: TComponent; 1405 Proc: TReadComponentsProc); 1406{$ifndef FPUNONE} 1407 function ReadFloat: Extended; 1408 function ReadSingle: Single; 1409 function ReadDate: TDateTime; 1410{$endif} 1411 function ReadCurrency: Currency; 1412 function ReadIdent: string; 1413 function ReadInteger: Longint; 1414 function ReadInt64: Int64; 1415 function ReadSet(EnumType: Pointer): Integer; 1416 procedure ReadListBegin; 1417 procedure ReadListEnd; 1418 function ReadRootComponent(ARoot: TComponent): TComponent; 1419 function ReadVariant: Variant; 1420 procedure ReadSignature; 1421 function ReadString: string; 1422 function ReadWideString: WideString; 1423 function ReadUnicodeString: UnicodeString; 1424 function ReadValue: TValueType; 1425 procedure CopyValue(Writer: TWriter); 1426 property Driver: TAbstractObjectReader read FDriver; 1427 property Owner: TComponent read FOwner write FOwner; 1428 property Parent: TComponent read FParent write FParent; 1429 property OnError: TReaderError read FOnError write FOnError; 1430 property OnPropertyNotFound: TPropertyNotFoundEvent read FOnPropertyNotFound write FOnPropertyNotFound; 1431 property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod; 1432 property OnSetMethodProperty: TSetMethodPropertyEvent read FOnSetMethodProperty write FOnSetMethodProperty; 1433 property OnSetName: TSetNameEvent read FOnSetName write FOnSetName; 1434 property OnReferenceName: TReferenceNameEvent read FOnReferenceName write FOnReferenceName; 1435 property OnAncestorNotFound: TAncestorNotFoundEvent read FOnAncestorNotFound write FOnAncestorNotFound; 1436 property OnCreateComponent: TCreateComponentEvent read FOnCreateComponent write FOnCreateComponent; 1437 property OnFindComponentClass: TFindComponentClassEvent read FOnFindComponentClass write FOnFindComponentClass; 1438 property OnReadStringProperty: TReadWriteStringPropertyEvent read FOnReadStringProperty write FOnReadStringProperty; 1439 end; 1440 1441 1442{ TWriter } 1443 1444 { TAbstractObjectWriter } 1445 1446 TAbstractObjectWriter = class 1447 public 1448 { Begin/End markers. Those ones who don't have an end indicator, use 1449 "EndList", after the occurrence named in the comment. Note that this 1450 only counts for "EndList" calls on the same level; each BeginXXX call 1451 increases the current level. } 1452 procedure BeginCollection; virtual; abstract; { Ends with the next "EndList" } 1453 procedure BeginComponent(Component: TComponent; Flags: TFilerFlags; 1454 ChildPos: Integer); virtual; abstract; { Ends after the second "EndList" } 1455 procedure WriteSignature; virtual; abstract; 1456 procedure BeginList; virtual; abstract; 1457 procedure EndList; virtual; abstract; 1458 procedure BeginProperty(const PropName: String); virtual; abstract; 1459 procedure EndProperty; virtual; abstract; 1460 Procedure FlushBuffer; virtual; 1461 //Please don't use write, better use WriteBinary whenever possible 1462 procedure Write(const Buffer; Count: Longint); virtual;abstract; 1463 1464 procedure WriteBinary(const Buffer; Count: Longint); virtual; abstract; 1465 procedure WriteBoolean(Value: Boolean); virtual; abstract; 1466 // procedure WriteChar(Value: Char); 1467{$ifndef FPUNONE} 1468 procedure WriteFloat(const Value: Extended); virtual; abstract; 1469 procedure WriteSingle(const Value: Single); virtual; abstract; 1470 procedure WriteDate(const Value: TDateTime); virtual; abstract; 1471{$endif} 1472 procedure WriteCurrency(const Value: Currency); virtual; abstract; 1473 procedure WriteIdent(const Ident: string); virtual; abstract; 1474 procedure WriteInteger(Value: Int64); virtual; abstract; 1475 procedure WriteUInt64(Value: QWord); virtual; abstract; 1476 procedure WriteVariant(const Value: Variant); virtual; abstract; 1477 procedure WriteMethodName(const Name: String); virtual; abstract; 1478 procedure WriteSet(Value: LongInt; SetType: Pointer); virtual; abstract; 1479 procedure WriteString(const Value: String); virtual; abstract; 1480 procedure WriteWideString(const Value: WideString);virtual;abstract; 1481 procedure WriteUnicodeString(const Value: UnicodeString);virtual;abstract; 1482 end; 1483 1484 { TBinaryObjectWriter } 1485 1486 TBinaryObjectWriter = class(TAbstractObjectWriter) 1487 protected 1488 FStream: TStream; 1489 FBuffer: Pointer; 1490 FBufSize: Integer; 1491 FBufPos: Integer; 1492 FBufEnd: Integer; 1493 procedure WriteWord(w : word); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 1494 procedure WriteDWord(lw : longword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 1495 procedure WriteQWord(qw : qword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 1496{$ifndef FPUNONE} 1497 procedure WriteExtended(e : extended); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 1498{$endif} 1499 procedure WriteValue(Value: TValueType); 1500 public 1501 constructor Create(Stream: TStream; BufSize: Integer); 1502 destructor Destroy; override; 1503 procedure WriteSignature; override; 1504 procedure FlushBuffer; override; 1505 procedure BeginCollection; override; 1506 procedure BeginComponent(Component: TComponent; Flags: TFilerFlags; 1507 ChildPos: Integer); override; 1508 procedure BeginList; override; 1509 procedure EndList; override; 1510 procedure BeginProperty(const PropName: String); override; 1511 procedure EndProperty; override; 1512 1513 //Please don't use write, better use WriteBinary whenever possible 1514 procedure Write(const Buffer; Count: Longint); override; 1515 procedure WriteBinary(const Buffer; Count: LongInt); override; 1516 procedure WriteBoolean(Value: Boolean); override; 1517{$ifndef FPUNONE} 1518 procedure WriteFloat(const Value: Extended); override; 1519 procedure WriteSingle(const Value: Single); override; 1520 procedure WriteDate(const Value: TDateTime); override; 1521{$endif} 1522 procedure WriteCurrency(const Value: Currency); override; 1523 procedure WriteIdent(const Ident: string); override; 1524 procedure WriteInteger(Value: Int64); override; 1525 procedure WriteUInt64(Value: QWord); override; 1526 procedure WriteMethodName(const Name: String); override; 1527 procedure WriteSet(Value: LongInt; SetType: Pointer); override; 1528 procedure WriteStr(const Value: String); 1529 procedure WriteString(const Value: String); override; 1530 procedure WriteWideString(const Value: WideString); override; 1531 procedure WriteUnicodeString(const Value: UnicodeString); override; 1532 procedure WriteVariant(const VarValue: Variant);override; 1533 end; 1534 1535 TTextObjectWriter = class(TAbstractObjectWriter) 1536 end; 1537 1538 1539 TFindAncestorEvent = procedure (Writer: TWriter; Component: TComponent; 1540 const Name: string; var Ancestor, RootAncestor: TComponent) of object; 1541 TWriteMethodPropertyEvent = procedure (Writer: TWriter; Instance: TPersistent; 1542 PropInfo: PPropInfo; 1543 const MethodValue, DefMethodValue: TMethod; 1544 var Handled: boolean) of object; 1545 1546 TWriter = class(TFiler) 1547 private 1548 FDriver: TAbstractObjectWriter; 1549 FDestroyDriver: Boolean; 1550 FRootAncestor: TComponent; 1551 FPropPath: String; 1552 FAncestors: TStringList; 1553 FAncestorPos: Integer; 1554 FCurrentPos: Integer; 1555 FOnFindAncestor: TFindAncestorEvent; 1556 FOnWriteMethodProperty: TWriteMethodPropertyEvent; 1557 FOnWriteStringProperty:TReadWriteStringPropertyEvent; 1558 procedure AddToAncestorList(Component: TComponent); 1559 procedure WriteComponentData(Instance: TComponent); 1560 Procedure DetermineAncestor(Component: TComponent); 1561 procedure DoFindAncestor(Component : TComponent); 1562 protected 1563 procedure SetRoot(ARoot: TComponent); override; 1564 procedure WriteBinary(AWriteData: TStreamProc); 1565 procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer); 1566 procedure WriteProperties(Instance: TPersistent); 1567 procedure WriteChildren(Component: TComponent); 1568 function CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectWriter; virtual; 1569 public 1570 constructor Create(ADriver: TAbstractObjectWriter); 1571 constructor Create(Stream: TStream; BufSize: Integer); 1572 destructor Destroy; override; 1573 Procedure FlushBuffer; override; 1574 procedure DefineProperty(const Name: string; 1575 ReadData: TReaderProc; AWriteData: TWriterProc; 1576 HasData: Boolean); override; 1577 procedure DefineBinaryProperty(const Name: string; 1578 ReadData, AWriteData: TStreamProc; 1579 HasData: Boolean); override; 1580 //Please don't use write, better use WriteBinary whenever possible 1581 //uuups, WriteBinary is protected .. 1582 procedure Write(const Buffer; Count: Longint); virtual; 1583 procedure WriteBoolean(Value: Boolean); 1584 procedure WriteCollection(Value: TCollection); 1585 procedure WriteComponent(Component: TComponent); 1586 procedure WriteChar(Value: Char); 1587 procedure WriteWideChar(Value: WideChar); 1588 procedure WriteDescendent(ARoot: TComponent; AAncestor: TComponent); 1589{$ifndef FPUNONE} 1590 procedure WriteFloat(const Value: Extended); 1591 procedure WriteSingle(const Value: Single); 1592 procedure WriteDate(const Value: TDateTime); 1593{$endif} 1594 procedure WriteCurrency(const Value: Currency); 1595 procedure WriteIdent(const Ident: string); 1596 procedure WriteInteger(Value: Longint); overload; 1597 procedure WriteInteger(Value: Int64); overload; 1598 procedure WriteSet(Value: LongInt; SetType: Pointer); 1599 procedure WriteListBegin; 1600 procedure WriteListEnd; 1601 Procedure WriteSignature; 1602 procedure WriteRootComponent(ARoot: TComponent); 1603 procedure WriteString(const Value: string); 1604 procedure WriteWideString(const Value: WideString); 1605 procedure WriteUnicodeString(const Value: UnicodeString); 1606 procedure WriteVariant(const VarValue: Variant); 1607 property RootAncestor: TComponent read FRootAncestor write FRootAncestor; 1608 property OnFindAncestor: TFindAncestorEvent read FOnFindAncestor write FOnFindAncestor; 1609 property OnWriteMethodProperty: TWriteMethodPropertyEvent read FOnWriteMethodProperty write FOnWriteMethodProperty; 1610 property OnWriteStringProperty: TReadWriteStringPropertyEvent read FOnWriteStringProperty write FOnWriteStringProperty; 1611 1612 property Driver: TAbstractObjectWriter read FDriver; 1613 property PropertyPath: string read FPropPath; 1614 end; 1615 1616 1617{ TParser } 1618 1619 TParser = class(TObject) 1620 private 1621 fStream : TStream; 1622 fBuf : pchar; 1623 fBufLen : integer; 1624 fPos : integer; 1625 fDeltaPos : integer; 1626 fFloatType : char; 1627 fSourceLine : integer; 1628 fToken : char; 1629 fEofReached : boolean; 1630 fLastTokenStr : string; 1631 fLastTokenWStr : widestring; 1632 function GetTokenName(aTok : char) : string; 1633 procedure LoadBuffer; 1634 procedure CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 1635 procedure ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 1636 function IsNumber : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 1637 function IsHexNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 1638 function IsAlpha : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 1639 function IsAlphaNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 1640 function GetHexValue(c : char) : byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} 1641 function GetAlphaNum : string; 1642 procedure HandleNewLine; 1643 procedure SkipBOM; 1644 procedure SkipSpaces; 1645 procedure SkipWhitespace; 1646 procedure HandleEof; 1647 procedure HandleAlphaNum; 1648 procedure HandleNumber; 1649 procedure HandleHexNumber; 1650 function HandleQuotedString : string; 1651 procedure HandleDecimalCharacter(var ascii : boolean; 1652 out WideChr: widechar; out StringChr: char); 1653 procedure HandleString; 1654 procedure HandleMinus; 1655 procedure HandleUnknown; 1656 public 1657 constructor Create(Stream: TStream); 1658 destructor Destroy; override; 1659 procedure CheckToken(T: Char); 1660 procedure CheckTokenSymbol(const S: string); 1661 procedure Error(const Ident: string); 1662 procedure ErrorFmt(const Ident: string; const Args: array of const); 1663 procedure ErrorStr(const Message: string); 1664 procedure HexToBinary(Stream: TStream); 1665 function NextToken: Char; 1666 function SourcePos: Longint; 1667 function TokenComponentIdent: string; 1668{$ifndef FPUNONE} 1669 function TokenFloat: Extended; 1670{$endif} 1671 function TokenInt: Int64; 1672 function TokenString: string; 1673 function TokenWideString: WideString; 1674 function TokenSymbolIs(const S: string): Boolean; 1675 property FloatType: Char read fFloatType; 1676 property SourceLine: Integer read fSourceLine; 1677 property Token: Char read fToken; 1678 end; 1679 1680{ TThread } 1681 TThread = Class; 1682 1683 EThread = class(Exception); 1684 EThreadExternalException = class(EThread); 1685 EThreadDestroyCalled = class(EThread); 1686 TSynchronizeProcVar = procedure; 1687 TThreadMethod = procedure of object; 1688 1689 TThreadReportStatus = Procedure(Const status : String) of Object; 1690 1691 TThreadStatusNotifyEvent = Procedure(Sender : TThread; Const status : String) of Object; 1692 TThreadExecuteHandler = TThreadMethod; 1693 TThreadExecuteStatusHandler = Procedure(ReportStatus : TThreadReportStatus) of object; 1694 1695 TNotifyCallBack = Procedure(Sender : TObject; AData : Pointer); 1696 TThreadStatusNotifyCallBack = Procedure(Sender : TThread; AData : Pointer; Const status : String); 1697 TThreadExecuteCallBack = Procedure(AData : Pointer); 1698 TThreadExecuteStatusCallBack = Procedure(AData : Pointer; ReportStatus : TThreadReportStatus); 1699 1700 TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest, 1701 tpTimeCritical); 1702 1703 1704 1705 TThread = class 1706 private type 1707 PThreadQueueEntry = ^TThreadQueueEntry; 1708 TThreadQueueEntry = record 1709 Method: TThreadMethod; 1710 // uncomment once closures are supported 1711 //ThreadProc: TThreadProcedure; 1712 Thread: TThread; 1713 ThreadID: TThreadID; 1714 Exception: TObject; 1715 SyncEvent: PRtlEvent; 1716 Next: PThreadQueueEntry; 1717 end; 1718 public type 1719 TSystemTimes = record 1720 IdleTime: QWord; 1721 UserTime: QWord; 1722 KernelTime: QWord; 1723 NiceTime: QWord; 1724 end; 1725 private 1726 class var FProcessorCount: LongWord; 1727 private 1728 FHandle: TThreadID; 1729 FTerminated: Boolean; 1730 FFreeOnTerminate: Boolean; 1731 FFinished: Boolean; 1732 FSuspended: LongBool; 1733 FReturnValue: Integer; 1734 FOnTerminate: TNotifyEvent; 1735 FFatalException: TObject; 1736 FExternalThread: Boolean; 1737 FSynchronizeEntry: PThreadQueueEntry; 1738 class function GetCurrentThread: TThread; static; 1739 class function GetIsSingleProcessor: Boolean; static; inline; 1740 class procedure InternalQueue(aThread: TThread; aMethod: TThreadMethod; aQueueIfMain: Boolean); static; 1741 procedure CallOnTerminate; 1742 function GetPriority: TThreadPriority; 1743 procedure SetPriority(Value: TThreadPriority); 1744 procedure SetSuspended(Value: Boolean); 1745 function GetSuspended: Boolean; 1746 procedure InitSynchronizeEvent; 1747 procedure DoneSynchronizeEvent; 1748 { these two need to be implemented per platform } 1749 procedure SysCreate(CreateSuspended: Boolean; 1750 const StackSize: SizeUInt); 1751 procedure SysDestroy; 1752 protected 1753 FThreadID: TThreadID; // someone might need it for pthread_* calls 1754 procedure DoTerminate; virtual; 1755 procedure TerminatedSet; virtual; 1756 procedure Execute; virtual; abstract; 1757 procedure Synchronize(AMethod: TThreadMethod); 1758 procedure Queue(aMethod: TThreadMethod); 1759 procedure ForceQueue(aMethod: TThreadMethod); inline; 1760 property ReturnValue: Integer read FReturnValue write FReturnValue; 1761 property Terminated: Boolean read FTerminated; 1762{$if defined(windows) or defined(OS2)} 1763 private 1764 FInitialSuspended: boolean; 1765{$endif} 1766{$ifdef Unix} 1767 private 1768 // see tthread.inc, ThreadFunc and TThread.Resume 1769 FSuspendEvent: PRTLEvent; 1770 FInitialSuspended: boolean; 1771 FSuspendedInternal: longbool; 1772 FThreadReaped: boolean; 1773{$endif} 1774{$ifdef netwlibc} 1775 private 1776 // see tthread.inc, ThreadFunc and TThread.Resume 1777 FSem: Pointer; 1778 FInitialSuspended: boolean; 1779 FSuspendedExternal: boolean; 1780 FPid: LongInt; 1781{$endif} 1782{$if defined(hasamiga)} 1783 private 1784 FInitialSuspended: boolean; 1785{$endif} 1786{$ifdef beos} 1787 FSem : pointer; 1788 FSuspendedExternal: boolean; 1789{$endif} 1790 public 1791 constructor Create(CreateSuspended: Boolean; 1792 const StackSize: SizeUInt = DefaultStackSize); 1793 destructor Destroy; override; 1794 { Note: Once closures are supported aProc will be changed to TProc } 1795 class function CreateAnonymousThread(aProc: TProcedure): TThread; static; 1796 class procedure NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID = TThreadID(-1)); static; inline; 1797 class procedure NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID = TThreadID(-1)); static; inline; 1798 class procedure SetReturnValue(aValue: Integer); static; 1799 class function CheckTerminated: Boolean; static; 1800 class procedure Synchronize(AThread: TThread; AMethod: TThreadMethod); 1801 class procedure Queue(aThread: TThread; aMethod: TThreadMethod); static; 1802 class procedure ForceQueue(aThread: TThread; aMethod: TThreadMethod); inline; static; 1803 class procedure RemoveQueuedEvents(aThread: TThread; aMethod: TThreadMethod); static; 1804 class procedure RemoveQueuedEvents(aMethod: TThreadMethod); static; 1805 class procedure RemoveQueuedEvents(aThread: TThread); static; 1806 class procedure SpinWait(aIterations: LongWord); static; 1807 class procedure Sleep(aMilliseconds: Cardinal); static; 1808 class procedure Yield; static; 1809 { use HAS_TTHREAD_GETSYSTEMTIMES to implement a platform specific variant 1810 which does not return a zeroed record } 1811 class procedure GetSystemTimes(out aSystemTimes: TSystemTimes); static; 1812 class function GetTickCount: LongWord; static; deprecated 'Use TThread.GetTickCount64 instead'; 1813 class function GetTickCount64: QWord; static; 1814 // Object based 1815 Class Function ExecuteInThread(AMethod : TThreadExecuteHandler; AOnTerminate : TNotifyEvent = Nil) : TThread; overload; static; 1816 Class Function ExecuteInThread(AMethod : TThreadExecuteStatusHandler; AOnStatus : TThreadStatusNotifyEvent; AOnTerminate : TNotifyEvent = Nil) : TThread; overload;static; 1817 // Plain methods. 1818 Class Function ExecuteInThread(AMethod : TThreadExecuteCallback; AData : Pointer = Nil; AOnTerminate: TNotifyCallBack = Nil) : TThread; overload;static; 1819 Class Function ExecuteInThread(AMethod : TThreadExecuteStatusCallback; AOnStatus : TThreadStatusNotifyCallback; AData : Pointer = Nil; AOnTerminate : TNotifyCallBack = Nil) : TThread; overload;static; 1820 procedure AfterConstruction; override; 1821 procedure Start; 1822 procedure Resume; deprecated; 1823 procedure Suspend; deprecated; 1824 procedure Terminate; 1825 function WaitFor: Integer; 1826 class property CurrentThread: TThread read GetCurrentThread; 1827 class property ProcessorCount: LongWord read FProcessorCount; 1828 class property IsSingleProcessor: Boolean read GetIsSingleProcessor; 1829 property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate; 1830 property Handle: TThreadID read FHandle; 1831 property ExternalThread: Boolean read FExternalThread; 1832 property Priority: TThreadPriority read GetPriority write SetPriority; 1833 property Suspended: Boolean read GetSuspended write SetSuspended; 1834 property Finished: Boolean read FFinished; 1835 property ThreadID: TThreadID read FThreadID; 1836 property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate; 1837 property FatalException: TObject read FFatalException; 1838 end; 1839 1840 1841{ TComponent class } 1842 1843 TOperation = (opInsert, opRemove); 1844 TComponentState = set of (csLoading, csReading, csWriting, csDestroying, 1845 csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification, 1846 csInline, csDesignInstance); 1847 TComponentStyle = set of (csInheritable, csCheckPropAvail, csSubComponent, 1848 csTransient); 1849 TGetChildProc = procedure (Child: TComponent) of object; 1850 1851 IVCLComObject = interface 1852 ['{E07892A0-F52F-11CF-BD2F-0020AF0E5B81}'] 1853 function GetTypeInfoCount(out Count: Integer): HResult; stdcall; 1854 function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; 1855 function GetIDsOfNames(const IID: TGUID; Names: Pointer; 1856 NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; 1857 function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; 1858 Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; 1859 function SafeCallException(ExceptObject: TObject; ExceptAddr: CodePointer): HResult; 1860 procedure FreeOnRelease; 1861 end; 1862 1863 IInterfaceComponentReference = interface 1864 ['{3FEEC8E1-E400-4A24-BCAC-1F01476439B1}'] 1865 function GetComponent:TComponent; 1866 end; 1867 1868 IDesignerNotify = interface 1869 ['{B971E807-E3A6-11D1-AAB1-00C04FB16FBC}'] 1870 procedure Modified; 1871 procedure Notification(AnObject: TPersistent; Operation: TOperation); 1872 end; 1873 1874 TComponentEnumerator = class 1875 private 1876 FComponent: TComponent; 1877 FPosition: Integer; 1878 public 1879 constructor Create(AComponent: TComponent); 1880 function GetCurrent: TComponent; 1881 function MoveNext: Boolean; 1882 property Current: TComponent read GetCurrent; 1883 end; 1884 1885 TBasicAction = class; 1886 1887 { TComponent } 1888 1889 TComponent = class(TPersistent,IUnknown,IInterfaceComponentReference) 1890 private 1891 FOwner: TComponent; 1892 FName: TComponentName; 1893 FTag: Ptrint; 1894 FComponents: TFpList; 1895 FFreeNotifies: TFpList; 1896 FDesignInfo: Longint; 1897 FVCLComObject: Pointer; 1898 FComponentState: TComponentState; 1899 function GetComObject: IUnknown; 1900 function GetComponent(AIndex: Integer): TComponent; 1901 function GetComponentCount: Integer; 1902 function GetComponentIndex: Integer; 1903 procedure Insert(AComponent: TComponent); 1904 procedure ReadLeft(Reader: TReader); 1905 procedure ReadTop(Reader: TReader); 1906 procedure Remove(AComponent: TComponent); 1907 procedure RemoveNotification(AComponent: TComponent); 1908 procedure SetComponentIndex(Value: Integer); 1909 procedure SetReference(Enable: Boolean); 1910 procedure WriteLeft(Writer: TWriter); 1911 procedure WriteTop(Writer: TWriter); 1912 protected 1913 FComponentStyle: TComponentStyle; 1914 procedure ChangeName(const NewName: TComponentName); 1915 procedure DefineProperties(Filer: TFiler); override; 1916 procedure GetChildren(Proc: TGetChildProc; Root: TComponent); dynamic; 1917 function GetChildOwner: TComponent; dynamic; 1918 function GetChildParent: TComponent; dynamic; 1919 function GetOwner: TPersistent; override; 1920 procedure Loaded; virtual; 1921 procedure Loading; virtual; 1922 procedure Notification(AComponent: TComponent; 1923 Operation: TOperation); virtual; 1924 procedure PaletteCreated; dynamic; 1925 procedure ReadState(Reader: TReader); virtual; 1926 procedure SetAncestor(Value: Boolean); 1927 procedure SetDesigning(Value: Boolean; SetChildren : Boolean = True); 1928 procedure SetDesignInstance(Value: Boolean); 1929 procedure SetInline(Value: Boolean); 1930 procedure SetName(const NewName: TComponentName); virtual; 1931 procedure SetChildOrder(Child: TComponent; Order: Integer); dynamic; 1932 procedure SetParentComponent(Value: TComponent); dynamic; 1933 procedure Updating; dynamic; 1934 procedure Updated; dynamic; 1935 class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); dynamic; 1936 procedure ValidateRename(AComponent: TComponent; 1937 const CurName, NewName: string); virtual; 1938 procedure ValidateContainer(AComponent: TComponent); dynamic; 1939 procedure ValidateInsert(AComponent: TComponent); dynamic; 1940 { IUnknown } 1941 function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): Hresult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 1942 function _AddRef: Longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 1943 function _Release: Longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 1944 function iicrGetComponent: TComponent; 1945 { IDispatch } 1946 function GetTypeInfoCount(out Count: Integer): HResult; stdcall; 1947 function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; 1948 function GetIDsOfNames(const IID: TGUID; Names: Pointer; 1949 NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; 1950 function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; 1951 Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; 1952 public 1953 //!! Moved temporary 1954 // fpdoc doesn't handle this yet :( 1955{$ifndef fpdocsystem} 1956 function IInterfaceComponentReference.GetComponent=iicrgetcomponent; 1957{$endif} 1958 procedure WriteState(Writer: TWriter); virtual; 1959 constructor Create(AOwner: TComponent); virtual; 1960 destructor Destroy; override; 1961 procedure BeforeDestruction; override; 1962 procedure DestroyComponents; 1963 procedure Destroying; 1964 function ExecuteAction(Action: TBasicAction): Boolean; dynamic; 1965 function FindComponent(const AName: string): TComponent; 1966 procedure FreeNotification(AComponent: TComponent); 1967 procedure RemoveFreeNotification(AComponent: TComponent); 1968 procedure FreeOnRelease; 1969 function GetEnumerator: TComponentEnumerator; 1970 function GetNamePath: string; override; 1971 function GetParentComponent: TComponent; dynamic; 1972 function HasParent: Boolean; dynamic; 1973 procedure InsertComponent(AComponent: TComponent); 1974 procedure RemoveComponent(AComponent: TComponent); 1975 function SafeCallException(ExceptObject: TObject; 1976 ExceptAddr: CodePointer): HResult; override; 1977 procedure SetSubComponent(ASubComponent: Boolean); 1978 function UpdateAction(Action: TBasicAction): Boolean; dynamic; 1979 property ComObject: IUnknown read GetComObject; 1980 function IsImplementorOf (const Intf:IInterface):boolean; 1981 procedure ReferenceInterface(const intf:IInterface;op:TOperation); 1982 property Components[Index: Integer]: TComponent read GetComponent; 1983 property ComponentCount: Integer read GetComponentCount; 1984 property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex; 1985 property ComponentState: TComponentState read FComponentState; 1986 property ComponentStyle: TComponentStyle read FComponentStyle; 1987 property DesignInfo: Longint read FDesignInfo write FDesignInfo; 1988 property Owner: TComponent read FOwner; 1989 property VCLComObject: Pointer read FVCLComObject write FVCLComObject; 1990 published 1991 property Name: TComponentName read FName write SetName stored False; 1992 property Tag: PtrInt read FTag write FTag default 0; 1993 end; 1994 1995{ TBasicActionLink } 1996 1997 TBasicActionLink = class(TObject) 1998 private 1999 FOnChange: TNotifyEvent; 2000 protected 2001 FAction: TBasicAction; 2002 procedure AssignClient(AClient: TObject); virtual; 2003 procedure Change; virtual; 2004 function IsOnExecuteLinked: Boolean; virtual; 2005 procedure SetAction(Value: TBasicAction); virtual; 2006 procedure SetOnExecute(Value: TNotifyEvent); virtual; 2007 public 2008 constructor Create(AClient: TObject); virtual; 2009 destructor Destroy; override; 2010 function Execute(AComponent: TComponent = nil): Boolean; virtual; 2011 function Update: Boolean; virtual; 2012 property Action: TBasicAction read FAction write SetAction; 2013 property OnChange: TNotifyEvent read FOnChange write FOnChange; 2014 end; 2015 2016 TBasicActionLinkClass = class of TBasicActionLink; 2017 2018{ TBasicAction } 2019 2020 TBasicAction = class(TComponent) 2021 private 2022 FActionComponent: TComponent; 2023 FOnChange: TNotifyEvent; 2024 FOnExecute: TNotifyEvent; 2025 FOnUpdate: TNotifyEvent; 2026 protected 2027 FClients: TFpList; 2028 procedure Change; virtual; 2029 procedure SetOnExecute(Value: TNotifyEvent); virtual; 2030 property OnChange: TNotifyEvent read FOnChange write FOnChange; 2031 public 2032 constructor Create(AOwner: TComponent); override; 2033 destructor Destroy; override; 2034 function HandlesTarget(Target: TObject): Boolean; virtual; 2035 procedure UpdateTarget(Target: TObject); virtual; 2036 procedure ExecuteTarget(Target: TObject); virtual; 2037 function Execute: Boolean; dynamic; 2038 procedure RegisterChanges(Value: TBasicActionLink); 2039 procedure UnRegisterChanges(Value: TBasicActionLink); 2040 function Update: Boolean; virtual; 2041 property ActionComponent: TComponent read FActionComponent write FActionComponent; 2042 property OnExecute: TNotifyEvent read FOnExecute write SetOnExecute; 2043 property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate; 2044 end; 2045 2046{ TBasicAction class reference type } 2047 2048 TBasicActionClass = class of TBasicAction; 2049 2050{ Component registration handlers } 2051 2052 TActiveXRegType = (axrComponentOnly, axrIncludeDescendants); 2053 2054 IInterfaceList = interface ['{285DEA8A-B865-11D1-AAA7-00C04FB17A72}'] 2055 function Get(i : Integer) : IUnknown; 2056 function GetCapacity : Integer; 2057 function GetCount : Integer; 2058 procedure Put(i : Integer;item : IUnknown); 2059 procedure SetCapacity(NewCapacity : Integer); 2060 procedure SetCount(NewCount : Integer); 2061 procedure Clear; 2062 procedure Delete(index : Integer); 2063 procedure Exchange(index1,index2 : Integer); 2064 function First : IUnknown; 2065 function IndexOf(const item : IUnknown) : Integer; 2066 function Add(item : IUnknown) : Integer; 2067 procedure Insert(i : Integer;item : IUnknown); 2068 function Last : IUnknown; 2069 function Remove(item : IUnknown): Integer; 2070 procedure Lock; 2071 procedure Unlock; 2072 property Capacity : Integer read GetCapacity write SetCapacity; 2073 property Count : Integer read GetCount write SetCount; 2074 property Items[index : Integer] : IUnknown read Get write Put;default; 2075 end; 2076 2077 TInterfaceList = class; 2078 2079 TInterfaceListEnumerator = class 2080 private 2081 FList: TInterfaceList; 2082 FPosition: Integer; 2083 public 2084 constructor Create(AList: TInterfaceList); 2085 function GetCurrent: IUnknown; 2086 function MoveNext: Boolean; 2087 property Current: IUnknown read GetCurrent; 2088 end; 2089 2090 TInterfaceList = class(TInterfacedObject,IInterfaceList) 2091 private 2092 FList : TThreadList; 2093 protected 2094 function Get(i : Integer) : IUnknown; 2095 function GetCapacity : Integer; 2096 function GetCount : Integer; 2097 procedure Put(i : Integer;item : IUnknown); 2098 procedure SetCapacity(NewCapacity : Integer); 2099 procedure SetCount(NewCount : Integer); 2100 public 2101 constructor Create; 2102 destructor Destroy; override; 2103 2104 procedure Clear; 2105 procedure Delete(index : Integer); 2106 procedure Exchange(index1,index2 : Integer); 2107 function First : IUnknown; 2108 function GetEnumerator: TInterfaceListEnumerator; 2109 function IndexOf(const item : IUnknown) : Integer; 2110 function Add(item : IUnknown) : Integer; 2111 procedure Insert(i : Integer;item : IUnknown); 2112 function Last : IUnknown; 2113 function Remove(item : IUnknown): Integer; 2114 procedure Lock; 2115 procedure Unlock; 2116 2117 function Expand : TInterfaceList; 2118 2119 property Capacity : Integer read GetCapacity write SetCapacity; 2120 property Count : Integer read GetCount write SetCount; 2121 property Items[Index : Integer] : IUnknown read Get write Put;default; 2122 end; 2123 2124{ --------------------------------------------------------------------- 2125 TDatamodule support 2126 ---------------------------------------------------------------------} 2127 TDataModule = class(TComponent) 2128 private 2129 FDPos: TPoint; 2130 FDSize: TPoint; 2131 FDPPI: Integer; 2132 FOnCreate: TNotifyEvent; 2133 FOnDestroy: TNotifyEvent; 2134 FOldOrder : Boolean; 2135 Procedure ReadP(Reader: TReader); 2136 Procedure WriteP(Writer: TWriter); 2137 Procedure ReadT(Reader: TReader); 2138 Procedure WriteT(Writer: TWriter); 2139 Procedure ReadL(Reader: TReader); 2140 Procedure WriteL(Writer: TWriter); 2141 Procedure ReadW(Reader: TReader); 2142 Procedure WriteW(Writer: TWriter); 2143 Procedure ReadH(Reader: TReader); 2144 Procedure WriteH(Writer: TWriter); 2145 protected 2146 Procedure DoCreate; virtual; 2147 Procedure DoDestroy; virtual; 2148 Procedure DefineProperties(Filer: TFiler); override; 2149 Procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; 2150 Function HandleCreateException: Boolean; virtual; 2151 Procedure ReadState(Reader: TReader); override; 2152 public 2153 constructor Create(AOwner: TComponent); override; 2154 Constructor CreateNew(AOwner: TComponent); 2155 Constructor CreateNew(AOwner: TComponent; CreateMode: Integer); virtual; 2156 destructor Destroy; override; 2157 Procedure AfterConstruction; override; 2158 Procedure BeforeDestruction; override; 2159 property DesignOffset: TPoint read FDPos write FDPos; 2160 property DesignSize: TPoint read FDSize write FDSize; 2161 property DesignPPI: Integer read FDPPI write FDPPI; 2162 published 2163 property OnCreate: TNotifyEvent read FOnCreate write FOnCreate; 2164 property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; 2165 property OldCreateOrder: Boolean read FOldOrder write FOldOrder; 2166 end; 2167 TDataModuleClass = Class of TDataModule; 2168 2169var 2170 // IDE hooks for TDatamodule support. 2171 AddDataModule : procedure (DataModule: TDataModule) of object; 2172 RemoveDataModule : procedure (DataModule: TDataModule) of object; 2173 ApplicationHandleException : procedure (Sender: TObject) of object; 2174 ApplicationShowException : procedure (E: Exception) of object; 2175 2176{ --------------------------------------------------------------------- 2177 tthread helpers 2178 ---------------------------------------------------------------------} 2179 2180{ function to be called when gui thread is ready to execute method 2181 result is true if a method has been executed 2182} 2183function CheckSynchronize(timeout : longint=0) : boolean; 2184 2185var 2186 { method proc that is called to trigger gui thread to execute a 2187method } 2188 WakeMainThread : TNotifyEvent = nil; 2189 2190{ --------------------------------------------------------------------- 2191 General streaming and registration routines 2192 ---------------------------------------------------------------------} 2193 2194 2195var 2196 RegisterComponentsProc: procedure(const Page: string; 2197 ComponentClasses: array of TComponentClass); 2198 RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass); 2199{!!!! RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass; 2200 AxRegType: TActiveXRegType) = nil; 2201 CurrentGroup: Integer = -1;} 2202 CreateVCLComObjectProc: procedure(Component: TComponent) = nil; 2203 2204{ Point and rectangle constructors } 2205 2206function Point(AX, AY: Integer): TPoint; 2207function SmallPoint(AX, AY: SmallInt): TSmallPoint; 2208function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect; 2209function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect; 2210 2211function PointsEqual(const P1, P2: TPoint): Boolean; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 2212function PointsEqual(const P1, P2: TSmallPoint): Boolean; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE} 2213function InvalidPoint(X, Y: Integer): Boolean; 2214function InvalidPoint(const At: TPoint): Boolean; 2215function InvalidPoint(const At: TSmallPoint): Boolean; 2216 2217{ Class registration routines } 2218 2219procedure RegisterClass(AClass: TPersistentClass); 2220procedure RegisterClasses(AClasses: array of TPersistentClass); 2221procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string); 2222procedure UnRegisterClass(AClass: TPersistentClass); 2223procedure UnRegisterClasses(AClasses: array of TPersistentClass); 2224procedure UnRegisterModuleClasses(Module: HMODULE); 2225function FindClass(const AClassName: string): TPersistentClass; 2226function GetClass(const AClassName: string): TPersistentClass; 2227procedure StartClassGroup(AClass: TPersistentClass); 2228procedure GroupDescendentsWith(AClass, AClassGroup: TPersistentClass); 2229function ActivateClassGroup(AClass: TPersistentClass): TPersistentClass; 2230function ClassGroupOf(AClass: TPersistentClass): TPersistentClass; 2231function ClassGroupOf(Instance: TPersistent): TPersistentClass; 2232 2233{ Component registration routines } 2234 2235procedure RegisterComponents(const Page: string; 2236 ComponentClasses: array of TComponentClass); 2237procedure RegisterNoIcon(ComponentClasses: array of TComponentClass); 2238procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass; 2239 AxRegType: TActiveXRegType); 2240 2241var 2242 GlobalNameSpace: IReadWriteSync; 2243 2244{ Object filing routines } 2245 2246type 2247 TIdentMapEntry = record 2248 Value: Integer; 2249 Name: String; 2250 end; 2251 2252 TIdentToInt = function(const Ident: string; var Int: Longint): Boolean; 2253 TIntToIdent = function(Int: Longint; var Ident: string): Boolean; 2254 TFindGlobalComponent = function(const Name: string): TComponent; 2255 TInitComponentHandler = function(Instance: TComponent; RootAncestor : TClass): boolean; 2256 2257var 2258 MainThreadID: TThreadID; 2259 2260procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToIntFn: TIdentToInt; 2261 IntToIdentFn: TIntToIdent); 2262function IdentToInt(const Ident: string; out Int: Longint; const Map: array of TIdentMapEntry): Boolean; 2263function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean; 2264function FindIntToIdent(AIntegerType: Pointer): TIntToIdent; 2265function FindIdentToInt(AIntegerType: Pointer): TIdentToInt; 2266 2267procedure RegisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent); 2268procedure UnregisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent); 2269function FindGlobalComponent(const Name: string): TComponent; 2270 2271function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean; 2272function InitComponentRes(const ResName: string; Instance: TComponent): Boolean; 2273function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent; 2274function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent; 2275function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent; 2276procedure WriteComponentResFile(const FileName: string; Instance: TComponent); 2277procedure RegisterInitComponentHandler(ComponentClass: TComponentClass; Handler: TInitComponentHandler); 2278 2279procedure GlobalFixupReferences; 2280procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings); 2281procedure GetFixupInstanceNames(Root: TComponent; 2282 const ReferenceRootName: string; Names: TStrings); 2283procedure RedirectFixupReferences(Root: TComponent; const OldRootName, 2284 NewRootName: string); 2285procedure RemoveFixupReferences(Root: TComponent; const RootName: string); 2286procedure RemoveFixups(Instance: TPersistent); 2287Function FindNestedComponent(Root : TComponent; APath : String; CStyle : Boolean = True) : TComponent; 2288 2289procedure BeginGlobalLoading; 2290procedure NotifyGlobalLoading; 2291procedure EndGlobalLoading; 2292 2293function CollectionsEqual(C1, C2: TCollection): Boolean; 2294function CollectionsEqual(C1, C2: TCollection; Owner1, Owner2: TComponent): Boolean; 2295 2296{ Object conversion routines } 2297 2298type 2299 TObjectTextEncoding = ( 2300 oteDFM, 2301 oteLFM 2302 ); 2303 2304procedure ObjectBinaryToText(Input, Output: TStream; Encoding: TObjectTextEncoding); 2305procedure ObjectBinaryToText(Input, Output: TStream); 2306procedure ObjectTextToBinary(Input, Output: TStream); 2307 2308procedure ObjectResourceToText(Input, Output: TStream); 2309procedure ObjectTextToResource(Input, Output: TStream); 2310 2311{ Utility routines } 2312 2313function LineStart(Buffer, BufPos: PChar): PChar; 2314procedure BinToHex(BinValue, HexValue: PChar; BinBufSize: Integer); 2315function HexToBin(HexValue, BinValue: PChar; BinBufSize: Integer): Integer; 2316function ExtractStrings(Separators, WhiteSpace: TSysCharSet; Content: PChar; Strings: TStrings; AddEmptyStrings : Boolean = False): Integer; 2317 2318