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