classesh.inc 49 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387
  1. {
  2. $Id$
  3. This file is part of the Free Component Library (FCL)
  4. Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. { We NEED ansistrings !!}
  12. {$H+}
  13. { The 1.0 compiler cannot compile the Seek(int64) overloading correct }
  14. {$ifndef ver1_0}
  15. {$define seek64bit}
  16. {$endif ver1_0}
  17. type
  18. { extra types to compile with FPC }
  19. HRSRC = longint;
  20. THANDLE = longint;
  21. TComponentName = string;
  22. {$ifdef ver1_0}
  23. // 1.0 doesn't have thread
  24. TRTLCriticalSection = record
  25. locked : longint;
  26. end;
  27. // 1.1 and above has interfaces
  28. IUnknown = class(TObject);
  29. TGUID = longint;
  30. {$endif ver1_0}
  31. HMODULE = longint;
  32. TPoint = record
  33. x,y : integer;
  34. end;
  35. TRect = record
  36. Case Integer of
  37. 0 : ( Left,Top,Right,Bottom : integer);
  38. 1 : ( TopLeft,BottomRight : TPoint);
  39. end;
  40. TSmallPoint = record
  41. x,y : smallint;
  42. end;
  43. const
  44. { Maximum TList size }
  45. MaxListSize = Maxint div 16;
  46. { values for TShortCut }
  47. scShift = $2000;
  48. scCtrl = $4000;
  49. scAlt = $8000;
  50. scNone = 0;
  51. { TStream seek origins }
  52. const
  53. soFromBeginning = 0;
  54. soFromCurrent = 1;
  55. soFromEnd = 2;
  56. type
  57. TSeekOrigin = (soBeginning, soCurrent, soEnd);
  58. { TFileStream create mode }
  59. const
  60. fmCreate = $FFFF;
  61. fmOpenRead = 0;
  62. fmOpenWrite = 1;
  63. fmOpenReadWrite = 2;
  64. { TParser special tokens }
  65. toEOF = Char(0);
  66. toSymbol = Char(1);
  67. toString = Char(2);
  68. toInteger = Char(3);
  69. toFloat = Char(4);
  70. Const
  71. FilerSignature : Array[1..4] of char = 'TPF0';
  72. type
  73. { Text alignment types }
  74. TAlignment = (taLeftJustify, taRightJustify, taCenter);
  75. { TLeftRight = taLeftJustify..taRightJustify; }
  76. { Types used by standard events }
  77. TShiftState = set of (ssShift, ssAlt, ssCtrl,
  78. ssLeft, ssRight, ssMiddle, ssDouble,
  79. // Extra additions
  80. ssMeta, ssSuper, ssHyper, ssAltGr, ssCaps, ssNum, ssScroll);
  81. THelpContext = -MaxLongint..MaxLongint;
  82. THelpType = (htKeyword, htContext);
  83. TShortCut = Low(Word)..High(Word);
  84. { Standard events }
  85. TNotifyEvent = procedure(Sender: TObject) of object;
  86. THelpEvent = function (Command: Word; Data: Longint;
  87. var CallHelp: Boolean): Boolean of object;
  88. TGetStrProc = procedure(const S: string) of object;
  89. { Exception classes }
  90. EStreamError = class(Exception);
  91. EFCreateError = class(EStreamError);
  92. EFOpenError = class(EStreamError);
  93. EFilerError = class(EStreamError);
  94. EReadError = class(EFilerError);
  95. EWriteError = class(EFilerError);
  96. EClassNotFound = class(EFilerError);
  97. EMethodNotFound = class(EFilerError);
  98. EInvalidImage = class(EFilerError);
  99. EResNotFound = class(Exception);
  100. EListError = class(Exception);
  101. EBitsError = class(Exception);
  102. EStringListError = class(Exception);
  103. EComponentError = class(Exception);
  104. EParserError = class(Exception);
  105. EOutOfResources = class(EOutOfMemory);
  106. EInvalidOperation = class(Exception);
  107. { Forward class declarations }
  108. TStream = class;
  109. TFiler = class;
  110. TReader = class;
  111. TWriter = class;
  112. TComponent = class;
  113. { TList class }
  114. PPointerList = ^TPointerList;
  115. TPointerList = array[0..MaxListSize - 1] of Pointer;
  116. TListSortCompare = function (Item1, Item2: Pointer): Integer;
  117. TListNotification = (lnAdded, lnExtracted, lnDeleted);
  118. TList = class(TObject)
  119. private
  120. FList: PPointerList;
  121. FCount: Integer;
  122. FCapacity: Integer;
  123. protected
  124. function Get(Index: Integer): Pointer;
  125. procedure Grow; virtual;
  126. procedure Put(Index: Integer; Item: Pointer);
  127. procedure Notify(Ptr: Pointer; Action: TListNotification); virtual;
  128. procedure SetCapacity(NewCapacity: Integer);
  129. procedure SetCount(NewCount: Integer);
  130. public
  131. destructor Destroy; override;
  132. function Add(Item: Pointer): Integer;
  133. procedure Clear; dynamic;
  134. procedure Delete(Index: Integer);
  135. class procedure Error(const Msg: string; Data: Integer); virtual;
  136. procedure Exchange(Index1, Index2: Integer);
  137. function Expand: TList;
  138. function Extract(item: Pointer): Pointer;
  139. function First: Pointer;
  140. function IndexOf(Item: Pointer): Integer;
  141. procedure Insert(Index: Integer; Item: Pointer);
  142. function Last: Pointer;
  143. procedure Move(CurIndex, NewIndex: Integer);
  144. function Remove(Item: Pointer): Integer;
  145. procedure Pack;
  146. procedure Sort(Compare: TListSortCompare);
  147. property Capacity: Integer read FCapacity write SetCapacity;
  148. property Count: Integer read FCount write SetCount;
  149. property Items[Index: Integer]: Pointer read Get write Put; default;
  150. property List: PPointerList read FList;
  151. end;
  152. { TThreadList class }
  153. TThreadList = class
  154. private
  155. FList: TList;
  156. FLock: TRTLCriticalSection;
  157. public
  158. constructor Create;
  159. destructor Destroy; override;
  160. procedure Add(Item: Pointer);
  161. procedure Clear;
  162. function LockList: TList;
  163. procedure Remove(Item: Pointer);
  164. procedure UnlockList;
  165. end;
  166. const
  167. BITSHIFT = 5;
  168. MASK = 31; {for longs that are 32-bit in size}
  169. MaxBitRec = $FFFF Div (SizeOf(longint));
  170. MaxBitFlags = MaxBitRec * 32;
  171. type
  172. TBitArray = array[0..MaxBitRec - 1] of cardinal;
  173. TBits = class(TObject)
  174. private
  175. { Private declarations }
  176. FBits : ^TBitArray;
  177. FSize : longint; { total longints currently allocated }
  178. findIndex : longint;
  179. findState : boolean;
  180. { functions and properties to match TBits class }
  181. procedure SetBit(bit : longint; value : Boolean);
  182. function GetSize : longint;
  183. procedure SetSize(value : longint);
  184. procedure CheckBitIndex (Bit : longint;CurrentSize : Boolean);
  185. public
  186. { Public declarations }
  187. constructor Create(TheSize : longint); virtual;
  188. destructor Destroy; override;
  189. function GetFSize : longint;
  190. procedure SetOn(Bit : longint);
  191. procedure Clear(Bit : longint);
  192. procedure Clearall;
  193. procedure AndBits(BitSet : TBits);
  194. procedure OrBits(BitSet : TBits);
  195. procedure XorBits(BitSet : TBits);
  196. procedure NotBits(BitSet : TBits);
  197. function Get(Bit : longint) : boolean;
  198. procedure Grow(NBit : longint);
  199. function Equals(BitSet : TBits) : Boolean;
  200. procedure SetIndex(Index : longint);
  201. function FindFirstBit(State : boolean) : longint;
  202. function FindNextBit : longint;
  203. function FindPrevBit : longint;
  204. { functions and properties to match TBits class }
  205. function OpenBit: longint;
  206. property Bits[Bit: longint]: Boolean read get write SetBit; default;
  207. property Size: longint read getSize write setSize;
  208. end;
  209. { TPersistent abstract class }
  210. {$M+}
  211. TPersistent = class(TObject)
  212. private
  213. procedure AssignError(Source: TPersistent);
  214. protected
  215. procedure AssignTo(Dest: TPersistent); virtual;
  216. procedure DefineProperties(Filer: TFiler); virtual;
  217. function GetOwner: TPersistent; dynamic;
  218. public
  219. destructor Destroy; override;
  220. procedure Assign(Source: TPersistent); virtual;
  221. function GetNamePath: string; virtual; {dynamic;}
  222. end;
  223. {$M-}
  224. { TPersistent class reference type }
  225. TPersistentClass = class of TPersistent;
  226. { TInterfaced Persistent }
  227. {$ifdef HASINTF}
  228. TInterfacedPersistent = class(TPersistent, IInterface)
  229. private
  230. FOwnerInterface: IInterface;
  231. protected
  232. { IInterface }
  233. function _AddRef: Integer; stdcall;
  234. function _Release: Integer; stdcall;
  235. public
  236. function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
  237. procedure AfterConstruction; override;
  238. end;
  239. {$endif HASINTF}
  240. { TRecall class }
  241. TRecall = class(TObject)
  242. private
  243. FStorage, FReference: TPersistent;
  244. public
  245. constructor Create(AStorage, AReference: TPersistent);
  246. destructor Destroy; override;
  247. procedure Store;
  248. procedure Forget;
  249. property Reference: TPersistent read FReference;
  250. end;
  251. { TCollection class }
  252. TCollection = class;
  253. TCollectionItem = class(TPersistent)
  254. private
  255. FCollection: TCollection;
  256. FID: Integer;
  257. function GetIndex: Integer;
  258. procedure SetCollection(Value: TCollection);
  259. protected
  260. procedure Changed(AllItems: Boolean);
  261. function GetNamePath: string; override;
  262. function GetOwner: TPersistent; override;
  263. function GetDisplayName: string; virtual;
  264. procedure SetIndex(Value: Integer); virtual;
  265. procedure SetDisplayName(const Value: string); virtual;
  266. public
  267. constructor Create(ACollection: TCollection); virtual;
  268. destructor Destroy; override;
  269. property Collection: TCollection read FCollection write SetCollection;
  270. property ID: Integer read FID;
  271. property Index: Integer read GetIndex write SetIndex;
  272. property DisplayName: string read GetDisplayName write SetDisplayName;
  273. end;
  274. TCollectionItemClass = class of TCollectionItem;
  275. TCollection = class(TPersistent)
  276. private
  277. FItemClass: TCollectionItemClass;
  278. FItems: TList;
  279. FUpdateCount: Integer;
  280. FNextID: Integer;
  281. FPropName: string;
  282. function GetCount: Integer;
  283. function GetPropName: string;
  284. procedure InsertItem(Item: TCollectionItem);
  285. procedure RemoveItem(Item: TCollectionItem);
  286. protected
  287. { Design-time editor support }
  288. function GetAttrCount: Integer; dynamic;
  289. function GetAttr(Index: Integer): string; dynamic;
  290. function GetItemAttr(Index, ItemIndex: Integer): string; dynamic;
  291. function GetNamePath: string; override;
  292. procedure Changed;
  293. function GetItem(Index: Integer): TCollectionItem;
  294. procedure SetItem(Index: Integer; Value: TCollectionItem);
  295. procedure SetItemName(Item: TCollectionItem); virtual;
  296. procedure SetPropName; virtual;
  297. procedure Update(Item: TCollectionItem); virtual;
  298. property PropName: string read GetPropName write FPropName;
  299. public
  300. constructor Create(AItemClass: TCollectionItemClass);
  301. destructor Destroy; override;
  302. function Add: TCollectionItem;
  303. procedure Assign(Source: TPersistent); override;
  304. procedure BeginUpdate;
  305. procedure Clear;
  306. procedure EndUpdate;
  307. function FindItemID(ID: Integer): TCollectionItem;
  308. property Count: Integer read GetCount;
  309. property ItemClass: TCollectionItemClass read FItemClass;
  310. property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
  311. end;
  312. TStrings = class;
  313. { IStringsAdapter interface }
  314. { Maintains link between TStrings and IStrings implementations }
  315. { !!!! Interfaces aren't supported by FPC
  316. IStringsAdapter = interface
  317. procedure ReferenceStrings(S: TStrings);
  318. procedure ReleaseStrings;
  319. end;
  320. }
  321. IStringsAdapter = class(TObject);
  322. { TStrings class }
  323. TStrings = class(TPersistent)
  324. private
  325. FUpdateCount: Integer;
  326. FAdapter: IStringsAdapter;
  327. function GetCommaText: string;
  328. function GetName(Index: Integer): string;
  329. function GetValue(const Name: string): string;
  330. procedure ReadData(Reader: TReader);
  331. procedure SetCommaText(const Value: string);
  332. procedure SetStringsAdapter(const Value: IStringsAdapter);
  333. procedure SetValue(const Name, Value: string);
  334. procedure WriteData(Writer: TWriter);
  335. protected
  336. procedure DefineProperties(Filer: TFiler); override;
  337. procedure Error(const Msg: string; Data: Integer);
  338. function Get(Index: Integer): string; virtual; abstract;
  339. function GetCapacity: Integer; virtual;
  340. function GetCount: Integer; virtual; abstract;
  341. function GetObject(Index: Integer): TObject; virtual;
  342. function GetTextStr: string; virtual;
  343. procedure Put(Index: Integer; const S: string); virtual;
  344. procedure PutObject(Index: Integer; AObject: TObject); virtual;
  345. procedure SetCapacity(NewCapacity: Integer); virtual;
  346. procedure SetTextStr(const Value: string); virtual;
  347. procedure SetUpdateState(Updating: Boolean); virtual;
  348. public
  349. destructor Destroy; override;
  350. function Add(const S: string): Integer; virtual;
  351. function AddObject(const S: string; AObject: TObject): Integer; virtual;
  352. procedure Append(const S: string);
  353. procedure AddStrings(TheStrings: TStrings); virtual;
  354. procedure Assign(Source: TPersistent); override;
  355. procedure BeginUpdate;
  356. procedure Clear; virtual; abstract;
  357. procedure Delete(Index: Integer); virtual; abstract;
  358. procedure EndUpdate;
  359. function Equals(TheStrings: TStrings): Boolean;
  360. procedure Exchange(Index1, Index2: Integer); virtual;
  361. function GetText: PChar; virtual;
  362. function IndexOf(const S: string): Integer; virtual;
  363. function IndexOfName(const Name: string): Integer;
  364. function IndexOfObject(AObject: TObject): Integer;
  365. procedure Insert(Index: Integer; const S: string); virtual; abstract;
  366. procedure InsertObject(Index: Integer; const S: string;
  367. AObject: TObject);
  368. procedure LoadFromFile(const FileName: string); virtual;
  369. procedure LoadFromStream(Stream: TStream); virtual;
  370. procedure Move(CurIndex, NewIndex: Integer); virtual;
  371. procedure SaveToFile(const FileName: string); virtual;
  372. procedure SaveToStream(Stream: TStream); virtual;
  373. procedure SetText(TheText: PChar); virtual;
  374. property Capacity: Integer read GetCapacity write SetCapacity;
  375. property CommaText: string read GetCommaText write SetCommaText;
  376. property Count: Integer read GetCount;
  377. property Names[Index: Integer]: string read GetName;
  378. property Objects[Index: Integer]: TObject read GetObject write PutObject;
  379. property Values[const Name: string]: string read GetValue write SetValue;
  380. property Strings[Index: Integer]: string read Get write Put; default;
  381. property Text: string read GetTextStr write SetTextStr;
  382. property StringsAdapter: IStringsAdapter read FAdapter write SetStringsAdapter;
  383. end;
  384. { TStringList class }
  385. TDuplicates = (dupIgnore, dupAccept, dupError);
  386. TStringList = class;
  387. PStringItem = ^TStringItem;
  388. TStringItem = record
  389. FString: string;
  390. FObject: TObject;
  391. end;
  392. PStringItemList = ^TStringItemList;
  393. TStringItemList = array[0..MaxListSize] of TStringItem;
  394. TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer;
  395. TStringList = class(TStrings)
  396. private
  397. FList: PStringItemList;
  398. FCount: Integer;
  399. FCapacity: Integer;
  400. FSorted: Boolean;
  401. FDuplicates: TDuplicates;
  402. FOnChange: TNotifyEvent;
  403. FOnChanging: TNotifyEvent;
  404. procedure ExchangeItems(Index1, Index2: Integer);
  405. procedure Grow;
  406. procedure QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
  407. procedure InsertItem(Index: Integer; const S: string);
  408. procedure SetSorted(Value: Boolean);
  409. protected
  410. procedure Changed; virtual;
  411. procedure Changing; virtual;
  412. function Get(Index: Integer): string; override;
  413. function GetCapacity: Integer; override;
  414. function GetCount: Integer; override;
  415. function GetObject(Index: Integer): TObject; override;
  416. procedure Put(Index: Integer; const S: string); override;
  417. procedure PutObject(Index: Integer; AObject: TObject); override;
  418. procedure SetCapacity(NewCapacity: Integer); override;
  419. procedure SetUpdateState(Updating: Boolean); override;
  420. public
  421. destructor Destroy; override;
  422. function Add(const S: string): Integer; override;
  423. procedure Clear; override;
  424. procedure Delete(Index: Integer); override;
  425. procedure Exchange(Index1, Index2: Integer); override;
  426. function Find(const S: string; var Index: Integer): Boolean; virtual;
  427. function IndexOf(const S: string): Integer; override;
  428. procedure Insert(Index: Integer; const S: string); override;
  429. procedure Sort; virtual;
  430. procedure CustomSort(CompareFn: TStringListSortCompare);
  431. property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  432. property Sorted: Boolean read FSorted write SetSorted;
  433. property OnChange: TNotifyEvent read FOnChange write FOnChange;
  434. property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  435. end;
  436. { TStream abstract class }
  437. TStream = class(TObject)
  438. private
  439. {$ifdef seek64bit}
  440. function GetPosition: Int64;
  441. procedure SetPosition(Pos: Int64);
  442. function GetSize: Int64;
  443. procedure SetSize64(NewSize: Int64);
  444. {$else seek64bit}
  445. function GetPosition: Longint;
  446. procedure SetPosition(Pos: Longint);
  447. function GetSize: Longint;
  448. {$endif seek64bit}
  449. protected
  450. {$ifdef seek64bit}
  451. procedure SetSize(NewSize: Longint); virtual;overload;
  452. procedure SetSize(NewSize: Int64); virtual;overload;
  453. {$else seek64bit}
  454. procedure SetSize(NewSize: Longint); virtual;
  455. {$endif seek64bit}
  456. public
  457. function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
  458. function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
  459. {$ifdef seek64bit}
  460. function Seek(Offset: Longint; Origin: Word): Longint; virtual; overload;
  461. function Seek(Offset: Int64; Origin: TSeekOrigin): Int64; virtual; overload;
  462. {$else seek64bit}
  463. function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
  464. {$endif seek64bit}
  465. procedure ReadBuffer(var Buffer; Count: Longint);
  466. procedure WriteBuffer(const Buffer; Count: Longint);
  467. function CopyFrom(Source: TStream; Count: Int64): Int64;
  468. function ReadComponent(Instance: TComponent): TComponent;
  469. function ReadComponentRes(Instance: TComponent): TComponent;
  470. procedure WriteComponent(Instance: TComponent);
  471. procedure WriteComponentRes(const ResName: string; Instance: TComponent);
  472. procedure WriteDescendent(Instance, Ancestor: TComponent);
  473. procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
  474. procedure WriteResourceHeader(const ResName: string; {!!!:out} var FixupInfo: Integer);
  475. procedure FixupResourceHeader(FixupInfo: Integer);
  476. procedure ReadResHeader;
  477. function ReadByte : Byte;
  478. function ReadWord : Word;
  479. function ReadDWord : Cardinal;
  480. function ReadAnsiString : String;
  481. procedure WriteByte(b : Byte);
  482. procedure WriteWord(w : Word);
  483. procedure WriteDWord(d : Cardinal);
  484. Procedure WriteAnsiString (S : String);
  485. {$ifdef seek64bit}
  486. property Position: Int64 read GetPosition write SetPosition;
  487. property Size: Int64 read GetSize write SetSize64;
  488. {$else seek64bit}
  489. property Position: Longint read GetPosition write SetPosition;
  490. property Size: Longint read GetSize write SetSize;
  491. {$endif seek64bit}
  492. end;
  493. {$ifdef HASINTF}
  494. IStreamPersist = interface ['{B8CD12A3-267A-11D4-83DA-00C04F60B2DD}']
  495. procedure LoadFromStream(Stream: TStream);
  496. procedure SaveToStream(Stream: TStream);
  497. end;
  498. {$endif HASINTF}
  499. { THandleStream class }
  500. THandleStream = class(TStream)
  501. private
  502. FHandle: Integer;
  503. protected
  504. {$ifdef seek64bit}
  505. procedure SetSize(NewSize: Longint); override;
  506. procedure SetSize(NewSize: Int64); override;
  507. {$else seek64bit}
  508. procedure SetSize(NewSize: Longint); override;
  509. {$endif seek64bit}
  510. public
  511. constructor Create(AHandle: Integer);
  512. function Read(var Buffer; Count: Longint): Longint; override;
  513. function Write(const Buffer; Count: Longint): Longint; override;
  514. {$ifdef seek64bit}
  515. function Seek(Offset: Int64; Origin: TSeekOrigin): Int64; override;
  516. {$else seek64bit}
  517. function Seek(Offset: Longint; Origin: Word): Longint; override;
  518. {$endif seek64bit}
  519. property Handle: Integer read FHandle;
  520. end;
  521. { TFileStream class }
  522. TFileStream = class(THandleStream)
  523. Private
  524. FFileName : String;
  525. public
  526. constructor Create(const AFileName: string; Mode: Word);
  527. constructor Create(const AFileName: string; Mode: Word; Rights: Cardinal);
  528. destructor Destroy; override;
  529. property FileName : String Read FFilename;
  530. end;
  531. { TCustomMemoryStream abstract class }
  532. TCustomMemoryStream = class(TStream)
  533. private
  534. FMemory: Pointer;
  535. FSize, FPosition: Longint;
  536. protected
  537. procedure SetPointer(Ptr: Pointer; ASize: Longint);
  538. public
  539. function Read(var Buffer; Count: Longint): Longint; override;
  540. function Seek(Offset: Longint; Origin: Word): Longint; override;
  541. procedure SaveToStream(Stream: TStream);
  542. procedure SaveToFile(const FileName: string);
  543. property Memory: Pointer read FMemory;
  544. end;
  545. { TMemoryStream }
  546. TMemoryStream = class(TCustomMemoryStream)
  547. private
  548. FCapacity: Longint;
  549. procedure SetCapacity(NewCapacity: Longint);
  550. protected
  551. function Realloc(var NewCapacity: Longint): Pointer; virtual;
  552. property Capacity: Longint read FCapacity write SetCapacity;
  553. public
  554. destructor Destroy; override;
  555. procedure Clear;
  556. procedure LoadFromStream(Stream: TStream);
  557. procedure LoadFromFile(const FileName: string);
  558. procedure SetSize(NewSize: Longint); override;
  559. function Write(const Buffer; Count: Longint): Longint; override;
  560. end;
  561. { TStringStream }
  562. TStringStream = class(TStream)
  563. private
  564. FDataString: string;
  565. FPosition: Integer;
  566. protected
  567. procedure SetSize(NewSize: Longint); override;
  568. public
  569. constructor Create(const AString: string);
  570. function Read(var Buffer; Count: Longint): Longint; override;
  571. function ReadString(Count: Longint): string;
  572. function Seek(Offset: Longint; Origin: Word): Longint; override;
  573. function Write(const Buffer; Count: Longint): Longint; override;
  574. procedure WriteString(const AString: string);
  575. property DataString: string read FDataString;
  576. end;
  577. { TResourceStream }
  578. TResourceStream = class(TCustomMemoryStream)
  579. private
  580. HResInfo: HRSRC;
  581. HGlobal: THandle;
  582. procedure Initialize(Instance: THandle; Name, ResType: PChar);
  583. public
  584. constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
  585. constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
  586. destructor Destroy; override;
  587. function Write(const Buffer; Count: Longint): Longint; override;
  588. end;
  589. { TStreamAdapter }
  590. { Implements OLE IStream on VCL TStream }
  591. { we don't need that yet
  592. TStreamAdapter = class(TInterfacedObject, IStream)
  593. private
  594. FStream: TStream;
  595. public
  596. constructor Create(Stream: TStream);
  597. function Read(pv: Pointer; cb: Longint;
  598. pcbRead: PLongint): HResult; stdcall;
  599. function Write(pv: Pointer; cb: Longint;
  600. pcbWritten: PLongint): HResult; stdcall;
  601. function Seek(dlibMove: Largeint; dwOrigin: Longint;
  602. out libNewPosition: Largeint): HResult; stdcall;
  603. function SetSize(libNewSize: Largeint): HResult; stdcall;
  604. function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
  605. out cbWritten: Largeint): HResult; stdcall;
  606. function Commit(grfCommitFlags: Longint): HResult; stdcall;
  607. function Revert: HResult; stdcall;
  608. function LockRegion(libOffset: Largeint; cb: Largeint;
  609. dwLockType: Longint): HResult; stdcall;
  610. function UnlockRegion(libOffset: Largeint; cb: Largeint;
  611. dwLockType: Longint): HResult; stdcall;
  612. function Stat(out statstg: TStatStg;
  613. grfStatFlag: Longint): HResult; stdcall;
  614. function Clone(out stm: IStream): HResult; stdcall;
  615. end;
  616. }
  617. { TFiler }
  618. TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
  619. vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
  620. vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64);
  621. TFilerFlag = (ffInherited, ffChildPos, ffInline);
  622. TFilerFlags = set of TFilerFlag;
  623. TReaderProc = procedure(Reader: TReader) of object;
  624. TWriterProc = procedure(Writer: TWriter) of object;
  625. TStreamProc = procedure(Stream: TStream) of object;
  626. TFiler = class(TObject)
  627. private
  628. FRoot: TComponent;
  629. FLookupRoot: TComponent;
  630. FAncestor: TPersistent;
  631. FIgnoreChildren: Boolean;
  632. protected
  633. procedure SetRoot(ARoot: TComponent); virtual;
  634. public
  635. procedure DefineProperty(const Name: string;
  636. ReadData: TReaderProc; WriteData: TWriterProc;
  637. HasData: Boolean); virtual; abstract;
  638. procedure DefineBinaryProperty(const Name: string;
  639. ReadData, WriteData: TStreamProc;
  640. HasData: Boolean); virtual; abstract;
  641. property Root: TComponent read FRoot write SetRoot;
  642. property LookupRoot: TComponent read FLookupRoot;
  643. property Ancestor: TPersistent read FAncestor write FAncestor;
  644. property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren;
  645. end;
  646. { TComponent class reference type }
  647. TComponentClass = class of TComponent;
  648. { TReader }
  649. TAbstractObjectReader = class
  650. public
  651. function NextValue: TValueType; virtual; abstract;
  652. function ReadValue: TValueType; virtual; abstract;
  653. procedure BeginRootComponent; virtual; abstract;
  654. procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
  655. var CompClassName, CompName: String); virtual; abstract;
  656. function BeginProperty: String; virtual; abstract;
  657. { All ReadXXX methods are called _after_ the value type has been read! }
  658. procedure ReadBinary(const DestData: TMemoryStream); virtual; abstract;
  659. function ReadFloat: Extended; virtual; abstract;
  660. function ReadSingle: Single; virtual; abstract;
  661. {!!!: function ReadCurrency: Currency; virtual; abstract;}
  662. function ReadDate: TDateTime; virtual; abstract;
  663. function ReadIdent(ValueType: TValueType): String; virtual; abstract;
  664. function ReadInt8: ShortInt; virtual; abstract;
  665. function ReadInt16: SmallInt; virtual; abstract;
  666. function ReadInt32: LongInt; virtual; abstract;
  667. function ReadInt64: Int64; virtual; abstract;
  668. function ReadSet(EnumType: Pointer): Integer; virtual; abstract;
  669. function ReadStr: String; virtual; abstract;
  670. function ReadString(StringType: TValueType): String; virtual; abstract;
  671. procedure SkipComponent(SkipComponentInfos: Boolean); virtual; abstract;
  672. procedure SkipValue; virtual; abstract;
  673. end;
  674. TBinaryObjectReader = class(TAbstractObjectReader)
  675. private
  676. FStream: TStream;
  677. FBuffer: Pointer;
  678. FBufSize: Integer;
  679. FBufPos: Integer;
  680. FBufEnd: Integer;
  681. procedure Read(var Buf; Count: LongInt);
  682. procedure SkipProperty;
  683. procedure SkipSetBody;
  684. public
  685. constructor Create(Stream: TStream; BufSize: Integer);
  686. destructor Destroy; override;
  687. function NextValue: TValueType; override;
  688. function ReadValue: TValueType; override;
  689. procedure BeginRootComponent; override;
  690. procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
  691. var CompClassName, CompName: String); override;
  692. function BeginProperty: String; override;
  693. procedure ReadBinary(const DestData: TMemoryStream); override;
  694. function ReadFloat: Extended; override;
  695. function ReadSingle: Single; override;
  696. {!!!: function ReadCurrency: Currency; override;}
  697. function ReadDate: TDateTime; override;
  698. function ReadIdent(ValueType: TValueType): String; override;
  699. function ReadInt8: ShortInt; override;
  700. function ReadInt16: SmallInt; override;
  701. function ReadInt32: LongInt; override;
  702. function ReadInt64: Int64; override;
  703. function ReadSet(EnumType: Pointer): Integer; override;
  704. function ReadStr: String; override;
  705. function ReadString(StringType: TValueType): String; override;
  706. procedure SkipComponent(SkipComponentInfos: Boolean); override;
  707. procedure SkipValue; override;
  708. end;
  709. TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
  710. var Address: Pointer; var Error: Boolean) of object;
  711. TSetNameEvent = procedure(Reader: TReader; Component: TComponent;
  712. var Name: string) of object;
  713. TReferenceNameEvent = procedure(Reader: TReader; var Name: string) of object;
  714. TAncestorNotFoundEvent = procedure(Reader: TReader; const ComponentName: string;
  715. ComponentClass: TPersistentClass; var Component: TComponent) of object;
  716. TReadComponentsProc = procedure(Component: TComponent) of object;
  717. TReaderError = procedure(Reader: TReader; const Message: string; var Handled: Boolean) of object;
  718. TFindComponentClassEvent = procedure(Reader: TReader; const ClassName: string;
  719. var ComponentClass: TComponentClass) of object;
  720. TCreateComponentEvent = procedure(Reader: TReader;
  721. ComponentClass: TComponentClass; var Component: TComponent) of object;
  722. TReader = class(TFiler)
  723. private
  724. FDriver: TAbstractObjectReader;
  725. FOwner: TComponent;
  726. FParent: TComponent;
  727. FFixups: TList;
  728. FLoaded: TList;
  729. FOnFindMethod: TFindMethodEvent;
  730. FOnSetName: TSetNameEvent;
  731. FOnReferenceName: TReferenceNameEvent;
  732. FOnAncestorNotFound: TAncestorNotFoundEvent;
  733. FOnError: TReaderError;
  734. FOnFindComponentClass: TFindComponentClassEvent;
  735. FOnCreateComponent: TCreateComponentEvent;
  736. FPropName: string;
  737. FCanHandleExcepts: Boolean;
  738. procedure DoFixupReferences;
  739. procedure FreeFixups;
  740. function FindComponentClass(const AClassName: string): TComponentClass;
  741. protected
  742. function Error(const Message: string): Boolean; virtual;
  743. function FindMethod(ARoot: TComponent; const AMethodName: string): Pointer; virtual;
  744. procedure ReadProperty(AInstance: TPersistent);
  745. procedure ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
  746. procedure PropertyError;
  747. procedure ReadData(Instance: TComponent);
  748. property PropName: string read FPropName;
  749. property CanHandleExceptions: Boolean read FCanHandleExcepts;
  750. public
  751. constructor Create(Stream: TStream; BufSize: Integer);
  752. destructor Destroy; override;
  753. procedure BeginReferences;
  754. procedure CheckValue(Value: TValueType);
  755. procedure DefineProperty(const Name: string;
  756. AReadData: TReaderProc; WriteData: TWriterProc;
  757. HasData: Boolean); override;
  758. procedure DefineBinaryProperty(const Name: string;
  759. AReadData, WriteData: TStreamProc;
  760. HasData: Boolean); override;
  761. function EndOfList: Boolean;
  762. procedure EndReferences;
  763. procedure FixupReferences;
  764. function NextValue: TValueType;
  765. function ReadBoolean: Boolean;
  766. function ReadChar: Char;
  767. procedure ReadCollection(Collection: TCollection);
  768. function ReadComponent(Component: TComponent): TComponent;
  769. procedure ReadComponents(AOwner, AParent: TComponent;
  770. Proc: TReadComponentsProc);
  771. function ReadFloat: Extended;
  772. function ReadSingle: Single;
  773. {!!!: function ReadCurrency: Currency;}
  774. function ReadDate: TDateTime;
  775. function ReadIdent: string;
  776. function ReadInteger: Longint;
  777. function ReadInt64: Int64;
  778. procedure ReadListBegin;
  779. procedure ReadListEnd;
  780. function ReadRootComponent(ARoot: TComponent): TComponent;
  781. function ReadString: string;
  782. {!!!: function ReadWideString: WideString;}
  783. function ReadValue: TValueType;
  784. procedure CopyValue(Writer: TWriter);
  785. property Driver: TAbstractObjectReader read FDriver;
  786. property Owner: TComponent read FOwner write FOwner;
  787. property Parent: TComponent read FParent write FParent;
  788. property OnError: TReaderError read FOnError write FOnError;
  789. property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod;
  790. property OnSetName: TSetNameEvent read FOnSetName write FOnSetName;
  791. property OnReferenceName: TReferenceNameEvent read FOnReferenceName write FOnReferenceName;
  792. property OnAncestorNotFound: TAncestorNotFoundEvent read FOnAncestorNotFound write FOnAncestorNotFound;
  793. property OnCreateComponent: TCreateComponentEvent read FOnCreateComponent write FOnCreateComponent;
  794. property OnFindComponentClass: TFindComponentClassEvent read FOnFindComponentClass write FOnFindComponentClass;
  795. end;
  796. { TWriter }
  797. TAbstractObjectWriter = class
  798. public
  799. { Begin/End markers. Those ones who don't have an end indicator, use
  800. "EndList", after the occurrence named in the comment. Note that this
  801. only counts for "EndList" calls on the same level; each BeginXXX call
  802. increases the current level. }
  803. procedure BeginCollection; virtual; abstract; { Ends with the next "EndList" }
  804. procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
  805. ChildPos: Integer); virtual; abstract; { Ends after the second "EndList" }
  806. procedure BeginList; virtual; abstract;
  807. procedure EndList; virtual; abstract;
  808. procedure BeginProperty(const PropName: String); virtual; abstract;
  809. procedure EndProperty; virtual; abstract;
  810. procedure WriteBinary(const Buffer; Count: Longint); virtual; abstract;
  811. procedure WriteBoolean(Value: Boolean); virtual; abstract;
  812. // procedure WriteChar(Value: Char);
  813. procedure WriteFloat(const Value: Extended); virtual; abstract;
  814. procedure WriteSingle(const Value: Single); virtual; abstract;
  815. {!!!: procedure WriteCurrency(const Value: Currency); virtual; abstract;}
  816. procedure WriteDate(const Value: TDateTime); virtual; abstract;
  817. procedure WriteIdent(const Ident: string); virtual; abstract;
  818. procedure WriteInteger(Value: Int64); virtual; abstract;
  819. procedure WriteMethodName(const Name: String); virtual; abstract;
  820. procedure WriteSet(Value: LongInt; SetType: Pointer); virtual; abstract;
  821. procedure WriteString(const Value: String); virtual; abstract;
  822. end;
  823. TBinaryObjectWriter = class(TAbstractObjectWriter)
  824. private
  825. FStream: TStream;
  826. FBuffer: Pointer;
  827. FBufSize: Integer;
  828. FBufPos: Integer;
  829. FBufEnd: Integer;
  830. FSignatureWritten: Boolean;
  831. procedure FlushBuffer;
  832. procedure Write(const Buffer; Count: Longint);
  833. procedure WriteValue(Value: TValueType);
  834. procedure WriteStr(const Value: String);
  835. public
  836. constructor Create(Stream: TStream; BufSize: Integer);
  837. destructor Destroy; override;
  838. procedure BeginCollection; override;
  839. procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
  840. ChildPos: Integer); override;
  841. procedure BeginList; override;
  842. procedure EndList; override;
  843. procedure BeginProperty(const PropName: String); override;
  844. procedure EndProperty; override;
  845. procedure WriteBinary(const Buffer; Count: LongInt); override;
  846. procedure WriteBoolean(Value: Boolean); override;
  847. procedure WriteFloat(const Value: Extended); override;
  848. procedure WriteSingle(const Value: Single); override;
  849. {!!!: procedure WriteCurrency(const Value: Currency); override;}
  850. procedure WriteDate(const Value: TDateTime); override;
  851. procedure WriteIdent(const Ident: string); override;
  852. procedure WriteInteger(Value: Int64); override;
  853. procedure WriteMethodName(const Name: String); override;
  854. procedure WriteSet(Value: LongInt; SetType: Pointer); override;
  855. procedure WriteString(const Value: String); override;
  856. end;
  857. TTextObjectWriter = class(TAbstractObjectWriter)
  858. end;
  859. TFindAncestorEvent = procedure (Writer: TWriter; Component: TComponent;
  860. const Name: string; var Ancestor, RootAncestor: TComponent) of object;
  861. TWriter = class(TFiler)
  862. private
  863. FDriver: TAbstractObjectWriter;
  864. FDestroyDriver: Boolean;
  865. FRootAncestor: TComponent;
  866. FPropPath: String;
  867. FAncestorList: TList;
  868. FAncestorPos: Integer;
  869. FChildPos: Integer;
  870. FOnFindAncestor: TFindAncestorEvent;
  871. procedure AddToAncestorList(Component: TComponent);
  872. procedure WriteComponentData(Instance: TComponent);
  873. protected
  874. procedure SetRoot(ARoot: TComponent); override;
  875. procedure WriteBinary(AWriteData: TStreamProc);
  876. procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  877. procedure WriteProperties(Instance: TPersistent);
  878. public
  879. constructor Create(ADriver: TAbstractObjectWriter);
  880. constructor Create(Stream: TStream; BufSize: Integer);
  881. destructor Destroy; override;
  882. procedure DefineProperty(const Name: string;
  883. ReadData: TReaderProc; AWriteData: TWriterProc;
  884. HasData: Boolean); override;
  885. procedure DefineBinaryProperty(const Name: string;
  886. ReadData, AWriteData: TStreamProc;
  887. HasData: Boolean); override;
  888. procedure WriteBoolean(Value: Boolean);
  889. procedure WriteCollection(Value: TCollection);
  890. procedure WriteComponent(Component: TComponent);
  891. procedure WriteChar(Value: Char);
  892. procedure WriteDescendent(ARoot: TComponent; AAncestor: TComponent);
  893. procedure WriteFloat(const Value: Extended);
  894. procedure WriteSingle(const Value: Single);
  895. {!!!: procedure WriteCurrency(const Value: Currency);}
  896. procedure WriteDate(const Value: TDateTime);
  897. procedure WriteIdent(const Ident: string);
  898. procedure WriteInteger(Value: Longint); overload;
  899. procedure WriteInteger(Value: Int64); overload;
  900. procedure WriteListBegin;
  901. procedure WriteListEnd;
  902. procedure WriteRootComponent(ARoot: TComponent);
  903. procedure WriteString(const Value: string);
  904. {!!!: procedure WriteWideString(const Value: WideString);}
  905. property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
  906. property OnFindAncestor: TFindAncestorEvent read FOnFindAncestor write FOnFindAncestor;
  907. property Driver: TAbstractObjectWriter read FDriver;
  908. end;
  909. { TParser }
  910. TParser = class(TObject)
  911. private
  912. FStream: TStream;
  913. FOrigin: Longint;
  914. FBuffer: PChar;
  915. FBufPtr: PChar;
  916. FBufEnd: PChar;
  917. FSourcePtr: PChar;
  918. FSourceEnd: PChar;
  919. FTokenPtr: PChar;
  920. FStringPtr: PChar;
  921. FSourceLine: Integer;
  922. FSaveChar: Char;
  923. FToken: Char;
  924. procedure ReadBuffer;
  925. procedure SkipBlanks;
  926. public
  927. constructor Create(Stream: TStream);
  928. destructor Destroy; override;
  929. procedure CheckToken(T: Char);
  930. procedure CheckTokenSymbol(const S: string);
  931. procedure Error(const Ident: string);
  932. procedure ErrorFmt(const Ident: string; const Args: array of const);
  933. procedure ErrorStr(const Message: string);
  934. procedure HexToBinary(Stream: TStream);
  935. function NextToken: Char;
  936. function SourcePos: Longint;
  937. function TokenComponentIdent: String;
  938. function TokenFloat: Extended;
  939. function TokenInt: Longint;
  940. function TokenString: string;
  941. function TokenSymbolIs(const S: string): Boolean;
  942. property SourceLine: Integer read FSourceLine;
  943. property Token: Char read FToken;
  944. end;
  945. { TThread }
  946. EThread = class(Exception);
  947. TThreadMethod = procedure of object;
  948. TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
  949. tpTimeCritical);
  950. TThread = class
  951. private
  952. FHandle: THandle;
  953. FThreadID: THandle;
  954. FTerminated: Boolean;
  955. FSuspended: Boolean;
  956. FFreeOnTerminate: Boolean;
  957. FFinished: Boolean;
  958. FReturnValue: Integer;
  959. FOnTerminate: TNotifyEvent;
  960. FMethod: TThreadMethod;
  961. FSynchronizeException: TObject;
  962. procedure CallOnTerminate;
  963. function GetPriority: TThreadPriority;
  964. procedure SetPriority(Value: TThreadPriority);
  965. procedure SetSuspended(Value: Boolean);
  966. protected
  967. procedure DoTerminate; virtual;
  968. procedure Execute; virtual; abstract;
  969. procedure Synchronize(Method: TThreadMethod);
  970. property ReturnValue: Integer read FReturnValue write FReturnValue;
  971. property Terminated: Boolean read FTerminated;
  972. public
  973. {$ifdef Unix}
  974. { Needed for linux }
  975. FStackPointer : integer;
  976. FStackSize : integer;
  977. FCallExitProcess : boolean;
  978. {$endif}
  979. constructor Create(CreateSuspended: Boolean);
  980. destructor Destroy; override;
  981. procedure Resume;
  982. procedure Suspend;
  983. procedure Terminate;
  984. function WaitFor: Integer;
  985. property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
  986. property Handle: THandle read FHandle;
  987. property Priority: TThreadPriority read GetPriority write SetPriority;
  988. property Suspended: Boolean read FSuspended write SetSuspended;
  989. property ThreadID: THandle read FThreadID;
  990. property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
  991. end;
  992. { TComponent class }
  993. TOperation = (opInsert, opRemove);
  994. TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
  995. csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification,
  996. csInline, csDesignInstance);
  997. TComponentStyle = set of (csInheritable, csCheckPropAvail);
  998. TGetChildProc = procedure (Child: TComponent) of object;
  999. {
  1000. TComponentName = type string;
  1001. IVCLComObject = interface
  1002. function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
  1003. function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
  1004. function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  1005. NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
  1006. function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  1007. Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
  1008. function SafeCallException(ExceptObject: TObject;
  1009. ExceptAddr: Pointer): Integer;
  1010. procedure FreeOnRelease;
  1011. end;
  1012. }
  1013. TComponent = class(TPersistent)
  1014. private
  1015. FOwner: TComponent;
  1016. FName: TComponentName;
  1017. FTag: Longint;
  1018. FComponents: TList;
  1019. FFreeNotifies: TList;
  1020. FDesignInfo: Longint;
  1021. FVCLComObject: Pointer;
  1022. FComponentState: TComponentState;
  1023. // function GetComObject: IUnknown;
  1024. function GetComponent(AIndex: Integer): TComponent;
  1025. function GetComponentCount: Integer;
  1026. function GetComponentIndex: Integer;
  1027. procedure Insert(AComponent: TComponent);
  1028. procedure ReadLeft(Reader: TReader);
  1029. procedure ReadTop(Reader: TReader);
  1030. procedure Remove(AComponent: TComponent);
  1031. procedure RemoveNotification(AComponent: TComponent);
  1032. procedure SetComponentIndex(Value: Integer);
  1033. procedure SetReference(Enable: Boolean);
  1034. procedure WriteLeft(Writer: TWriter);
  1035. procedure WriteTop(Writer: TWriter);
  1036. protected
  1037. FComponentStyle: TComponentStyle;
  1038. procedure ChangeName(const NewName: TComponentName);
  1039. procedure DefineProperties(Filer: TFiler); override;
  1040. procedure GetChildren(Proc: TGetChildProc; Root: TComponent); dynamic;
  1041. function GetChildOwner: TComponent; dynamic;
  1042. function GetChildParent: TComponent; dynamic;
  1043. function GetNamePath: string; override;
  1044. function GetOwner: TPersistent; override;
  1045. procedure Loaded; virtual;
  1046. procedure Notification(AComponent: TComponent;
  1047. Operation: TOperation); virtual;
  1048. procedure ReadState(Reader: TReader); virtual;
  1049. procedure SetAncestor(Value: Boolean);
  1050. procedure SetDesigning(Value: Boolean);
  1051. procedure SetName(const NewName: TComponentName); virtual;
  1052. procedure SetChildOrder(Child: TComponent; Order: Integer); dynamic;
  1053. procedure SetParentComponent(Value: TComponent); dynamic;
  1054. procedure Updating; dynamic;
  1055. procedure Updated; dynamic;
  1056. class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); dynamic;
  1057. procedure ValidateRename(AComponent: TComponent;
  1058. const CurName, NewName: string); virtual;
  1059. procedure ValidateContainer(AComponent: TComponent); dynamic;
  1060. procedure ValidateInsert(AComponent: TComponent); dynamic;
  1061. { IUnknown }
  1062. //!!!!! function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  1063. //!!!! function _AddRef: Integer; stdcall;
  1064. //!!!! function _Release: Integer; stdcall;
  1065. { IDispatch }
  1066. //!!!! function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
  1067. //!!!! function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
  1068. //!!!! function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  1069. //!!!! NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
  1070. //!!!! function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  1071. //!!!! Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
  1072. public
  1073. //!! Moved temporary
  1074. procedure WriteState(Writer: TWriter); virtual;
  1075. constructor Create(AOwner: TComponent); virtual;
  1076. destructor Destroy; override;
  1077. procedure DestroyComponents;
  1078. procedure Destroying;
  1079. function FindComponent(const AName: string): TComponent;
  1080. procedure FreeNotification(AComponent: TComponent);
  1081. procedure RemoveFreeNotification(AComponent: TComponent);
  1082. procedure FreeOnRelease;
  1083. function GetParentComponent: TComponent; dynamic;
  1084. function HasParent: Boolean; dynamic;
  1085. procedure InsertComponent(AComponent: TComponent);
  1086. procedure RemoveComponent(AComponent: TComponent);
  1087. function SafeCallException(ExceptObject: TObject;
  1088. ExceptAddr: Pointer): Integer; override;
  1089. // property ComObject: IUnknown read GetComObject;
  1090. property Components[Index: Integer]: TComponent read GetComponent;
  1091. property ComponentCount: Integer read GetComponentCount;
  1092. property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex;
  1093. property ComponentState: TComponentState read FComponentState;
  1094. property ComponentStyle: TComponentStyle read FComponentStyle;
  1095. property DesignInfo: Longint read FDesignInfo write FDesignInfo;
  1096. property Owner: TComponent read FOwner;
  1097. property VCLComObject: Pointer read FVCLComObject write FVCLComObject;
  1098. published
  1099. property Name: TComponentName read FName write SetName stored False;
  1100. property Tag: Longint read FTag write FTag default 0;
  1101. end;
  1102. { Component registration handlers }
  1103. TActiveXRegType = (axrComponentOnly, axrIncludeDescendants);
  1104. var
  1105. RegisterComponentsProc: procedure(const Page: string;
  1106. ComponentClasses: array of TComponentClass);
  1107. RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass);
  1108. {!!!! RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass;
  1109. AxRegType: TActiveXRegType) = nil;
  1110. CurrentGroup: Integer = -1;
  1111. CreateVCLComObjectProc: procedure(Component: TComponent) = nil;}
  1112. { Point and rectangle constructors }
  1113. function Point(AX, AY: Integer): TPoint;
  1114. function SmallPoint(AX, AY: SmallInt): TSmallPoint;
  1115. function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  1116. function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
  1117. { Class registration routines }
  1118. procedure RegisterClass(AClass: TPersistentClass);
  1119. procedure RegisterClasses(AClasses: array of TPersistentClass);
  1120. procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
  1121. procedure UnRegisterClass(AClass: TPersistentClass);
  1122. procedure UnRegisterClasses(AClasses: array of TPersistentClass);
  1123. procedure UnRegisterModuleClasses(Module: HMODULE);
  1124. function FindClass(const AClassName: string): TPersistentClass;
  1125. function GetClass(const AClassName: string): TPersistentClass;
  1126. { Component registration routines }
  1127. procedure RegisterComponents(const Page: string;
  1128. ComponentClasses: array of TComponentClass);
  1129. procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
  1130. procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass;
  1131. AxRegType: TActiveXRegType);
  1132. {!!!: var
  1133. GlobalNameSpace: TMultiReadExclusiveWriteSynchronizer;}
  1134. { Object filing routines }
  1135. type
  1136. TIdentMapEntry = record
  1137. Value: Integer;
  1138. Name: String;
  1139. end;
  1140. TIdentToInt = function(const Ident: string; var Int: Longint): Boolean;
  1141. TIntToIdent = function(Int: Longint; var Ident: string): Boolean;
  1142. TFindGlobalComponent = function(const Name: string): TComponent;
  1143. var
  1144. MainThreadID: THandle;
  1145. FindGlobalComponent: TFindGlobalComponent;
  1146. procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToIntFn: TIdentToInt;
  1147. IntToIdentFn: TIntToIdent);
  1148. function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
  1149. function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
  1150. function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
  1151. function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
  1152. function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
  1153. function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
  1154. function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
  1155. procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
  1156. procedure GlobalFixupReferences;
  1157. procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
  1158. procedure GetFixupInstanceNames(Root: TComponent;
  1159. const ReferenceRootName: string; Names: TStrings);
  1160. procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  1161. NewRootName: string);
  1162. procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
  1163. procedure RemoveFixups(Instance: TPersistent);
  1164. function FindNestedComponent(Root: TComponent; const NamePath: string): TComponent;
  1165. procedure BeginGlobalLoading;
  1166. procedure NotifyGlobalLoading;
  1167. procedure EndGlobalLoading;
  1168. function CollectionsEqual(C1, C2: TCollection): Boolean;
  1169. { Object conversion routines }
  1170. procedure ObjectBinaryToText(Input, Output: TStream);
  1171. procedure ObjectTextToBinary(Input, Output: TStream);
  1172. procedure ObjectResourceToText(Input, Output: TStream);
  1173. procedure ObjectTextToResource(Input, Output: TStream);
  1174. { Utility routines }
  1175. function LineStart(Buffer, BufPos: PChar): PChar;
  1176. {
  1177. $Log$
  1178. Revision 1.17 2001-12-03 21:39:58 peter
  1179. * seek(int64) overload only for 1.1 compiler
  1180. Revision 1.16 2001/11/24 20:41:04 carl
  1181. * fix Peter's problems with compiling under version 1.0
  1182. Revision 1.15 2001/11/20 18:53:29 peter
  1183. * overload fix
  1184. Revision 1.14 2001/10/29 19:38:13 michael
  1185. + Added TRect definition
  1186. Revision 1.13 2001/10/28 17:16:44 peter
  1187. * int64 file functions added
  1188. Revision 1.12 2001/10/23 21:51:02 peter
  1189. * criticalsection renamed to rtlcriticalsection for kylix compatibility
  1190. Revision 1.11 2001/08/12 22:10:36 peter
  1191. * some interface updates for 1.1
  1192. Revision 1.10 2001/05/14 21:17:24 florian
  1193. * TGUID and IUnknown is defined in the system unit by
  1194. 1.1 and above
  1195. Revision 1.9 2001/04/13 18:03:51 peter
  1196. * added tthread.destroy override
  1197. Revision 1.8 2001/02/09 20:38:28 sg
  1198. Merges from Fixbranch:
  1199. * Extended TRect type to have TopLeft and BottomRight fields as well
  1200. * Added "Driver" property to TReader
  1201. Revision 1.7 2001/02/02 23:51:27 peter
  1202. * bit field to cardinal instead of longint
  1203. Revision 1.6 2000/12/03 22:35:09 sg
  1204. * Applied patch by Markus Kaemmerer (merged):
  1205. - Added support for TStringList.CustomSort
  1206. Revision 1.5 2000/11/13 15:46:55 marco
  1207. * Unix renamefest for defines.
  1208. Revision 1.4 2000/10/15 10:04:39 peter
  1209. + Capitalization of TBits interface fixed; CheckBitIndex now checks for
  1210. size (merged)
  1211. Revision 1.3 2000/08/15 04:10:38 peter
  1212. * delphi compatibility fix
  1213. Revision 1.2 2000/07/13 11:32:59 michael
  1214. + removed logs
  1215. }