classes.inc 60 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437
  1. {
  2. This file is part of the Free Component Library (FCL)
  3. Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
  4. See the file COPYING.FPC, included in this distribution,
  5. for details about the copyright.
  6. This program is distributed in the hope that it will be useful,
  7. but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  9. **********************************************************************}
  10. {**********************************************************************
  11. * Class implementations are in separate files. *
  12. **********************************************************************}
  13. type
  14. {$ifdef CPU16}
  15. TFilerFlagsInt = Byte;
  16. {$else CPU16}
  17. TFilerFlagsInt = LongInt;
  18. {$endif CPU16}
  19. var
  20. ClassList : TThreadlist;
  21. ClassAliasList : TStringList;
  22. {
  23. Include all message strings
  24. Add a language with IFDEF LANG_NAME
  25. just befor the final ELSE. This way English will always be the default.
  26. }
  27. {$IFDEF LANG_GERMAN}
  28. {$i constsg.inc}
  29. {$ELSE}
  30. {$IFDEF LANG_SPANISH}
  31. {$i constss.inc}
  32. {$ENDIF}
  33. {$ENDIF}
  34. { Utility routines }
  35. {$i util.inc}
  36. { TBits implementation }
  37. {$i bits.inc}
  38. { All streams implementations: }
  39. { Tstreams THandleStream TFileStream TResourcseStreams TStringStream }
  40. { TCustomMemoryStream TMemoryStream }
  41. {$i streams.inc}
  42. { TParser implementation}
  43. {$i parser.inc}
  44. { TCollection and TCollectionItem implementations }
  45. {$i collect.inc}
  46. { TList and TThreadList implementations }
  47. {$i lists.inc}
  48. { TStrings and TStringList implementations }
  49. {$i stringl.inc}
  50. { TThread implementation }
  51. { system independend threading code }
  52. var
  53. { event executed by SychronizeInternal to wake main thread if it sleeps in
  54. CheckSynchronize }
  55. SynchronizeTimeoutEvent: PRtlEvent;
  56. { the head of the queue containing the entries to be Synchronized - Nil if the
  57. queue is empty }
  58. ThreadQueueHead: TThread.PThreadQueueEntry;
  59. { the tail of the queue containing the entries to be Synchronized - Nil if the
  60. queue is empty }
  61. ThreadQueueTail: TThread.PThreadQueueEntry;
  62. { used for serialized access to the queue }
  63. ThreadQueueLock: TRtlCriticalSection;
  64. { this list holds all instances of external threads that need to be freed at
  65. the end of the program }
  66. ExternalThreads: TThreadList;
  67. { this list signals that the ExternalThreads list is cleared and thus the
  68. thread instances don't need to remove themselves }
  69. ExternalThreadsCleanup: Boolean = False;
  70. { this must be a global var, otherwise unwanted optimizations might happen in
  71. TThread.SpinWait() }
  72. SpinWaitDummy: LongWord;
  73. threadvar
  74. { the instance of the current thread; in case of an external thread this is
  75. Nil until TThread.GetCurrentThread was called once (the RTLs need to ensure
  76. that threadvars are initialized with 0!) }
  77. CurrentThreadVar: TThread;
  78. type
  79. { this type is used if a thread is created using
  80. TThread.CreateAnonymousThread }
  81. TAnonymousThread = class(TThread)
  82. private
  83. fProc: TProcedure;
  84. protected
  85. procedure Execute; override;
  86. public
  87. { as in TThread aProc needs to be changed to TProc once closures are
  88. supported }
  89. constructor Create(aProc: TProcedure);
  90. end;
  91. procedure TAnonymousThread.Execute;
  92. begin
  93. fProc();
  94. end;
  95. constructor TAnonymousThread.Create(aProc: TProcedure);
  96. begin
  97. { an anonymous thread is created suspended and with FreeOnTerminate set }
  98. inherited Create(True);
  99. FreeOnTerminate := True;
  100. fProc := aProc;
  101. end;
  102. type
  103. { this type is used by TThread.GetCurrentThread if the thread does not yet
  104. have a value in CurrentThreadVar (Note: the main thread is also created as
  105. a TExternalThread) }
  106. TExternalThread = class(TThread)
  107. protected
  108. { dummy method to remove the warning }
  109. procedure Execute; override;
  110. public
  111. constructor Create;
  112. destructor Destroy; override;
  113. end;
  114. procedure TExternalThread.Execute;
  115. begin
  116. { empty }
  117. end;
  118. constructor TExternalThread.Create;
  119. begin
  120. FExternalThread := True;
  121. { the parameter is unimportant if FExternalThread is True }
  122. inherited Create(False);
  123. with ExternalThreads.LockList do
  124. try
  125. Add(Self);
  126. finally
  127. ExternalThreads.UnlockList;
  128. end;
  129. end;
  130. destructor TExternalThread.Destroy;
  131. begin
  132. inherited;
  133. if not ExternalThreadsCleanup then
  134. with ExternalThreads.LockList do
  135. try
  136. Extract(Self);
  137. finally
  138. ExternalThreads.UnlockList;
  139. end;
  140. end;
  141. function ThreadProc(ThreadObjPtr: Pointer): PtrInt;
  142. var
  143. FreeThread: Boolean;
  144. Thread: TThread absolute ThreadObjPtr;
  145. begin
  146. { if Suspend checks FSuspended before doing anything, make sure it }
  147. { knows we're currently not suspended (this flag may have been set }
  148. { to true if CreateSuspended was true) }
  149. // Thread.FSuspended:=false;
  150. // wait until AfterConstruction has been called, so we cannot
  151. // free ourselves before TThread.Create has finished
  152. // (since that one may check our VTM in case of $R+, and
  153. // will call the AfterConstruction method in all cases)
  154. // Thread.Suspend;
  155. try
  156. { The thread may be already terminated at this point, e.g. if it was intially
  157. suspended, or if it wasn't ever scheduled for execution for whatever reason.
  158. So bypass user code if terminated. }
  159. if not Thread.Terminated then begin
  160. CurrentThreadVar := Thread;
  161. Thread.Execute;
  162. end;
  163. except
  164. Thread.FFatalException := TObject(AcquireExceptionObject);
  165. end;
  166. FreeThread := Thread.FFreeOnTerminate;
  167. Result := Thread.FReturnValue;
  168. Thread.FFinished := True;
  169. Thread.DoTerminate;
  170. if FreeThread then
  171. Thread.Free;
  172. EndThread(Result);
  173. end;
  174. { system-dependent code }
  175. {$i tthread.inc}
  176. constructor TThread.Create(CreateSuspended: Boolean;
  177. const StackSize: SizeUInt);
  178. begin
  179. inherited Create;
  180. if FExternalThread then
  181. FThreadID := GetCurrentThreadID
  182. else
  183. SysCreate(CreateSuspended, StackSize);
  184. end;
  185. destructor TThread.Destroy;
  186. begin
  187. if not FExternalThread then begin
  188. SysDestroy;
  189. if FHandle <> TThreadID(0) then
  190. CloseThread(FHandle);
  191. end;
  192. RemoveQueuedEvents(Self);
  193. DoneSynchronizeEvent;
  194. { set CurrentThreadVar to Nil? }
  195. inherited Destroy;
  196. end;
  197. procedure TThread.Start;
  198. begin
  199. { suspend/resume are now deprecated in Delphi (they also don't work
  200. on most platforms in FPC), so a different method was required
  201. to start a thread if it's create with fSuspended=true -> that's
  202. what this method is for. }
  203. Resume;
  204. end;
  205. function TThread.GetSuspended: Boolean;
  206. begin
  207. GetSuspended:=FSuspended;
  208. end;
  209. procedure TThread.AfterConstruction;
  210. begin
  211. inherited AfterConstruction;
  212. // enable for all platforms once http://bugs.freepascal.org/view.php?id=16884
  213. // is fixed for all platforms (in case the fix for non-unix platforms also
  214. // requires this field at least)
  215. {$if defined(unix) or defined(windows) or defined(os2) or defined(hasamiga)}
  216. if not FExternalThread and not FInitialSuspended then
  217. Resume;
  218. {$endif}
  219. end;
  220. procedure ExecuteThreadQueueEntry(aEntry: TThread.PThreadQueueEntry);
  221. begin
  222. if Assigned(aEntry^.Method) then
  223. aEntry^.Method()
  224. // enable once closures are supported
  225. {else
  226. aEntry^.ThreadProc();}
  227. end;
  228. procedure ThreadQueueAppend(aEntry: TThread.PThreadQueueEntry);
  229. begin
  230. { do we really need a synchronized call? }
  231. if GetCurrentThreadID = MainThreadID then begin
  232. ExecuteThreadQueueEntry(aEntry);
  233. if not Assigned(aEntry^.SyncEvent) then
  234. Dispose(aEntry);
  235. end else begin
  236. System.EnterCriticalSection(ThreadQueueLock);
  237. try
  238. { add the entry to the thread queue }
  239. if Assigned(ThreadQueueTail) then begin
  240. ThreadQueueTail^.Next := aEntry;
  241. end else
  242. ThreadQueueHead := aEntry;
  243. ThreadQueueTail := aEntry;
  244. finally
  245. System.LeaveCriticalSection(ThreadQueueLock);
  246. end;
  247. { ensure that the main thread knows that something awaits }
  248. RtlEventSetEvent(SynchronizeTimeoutEvent);
  249. if assigned(WakeMainThread) then
  250. WakeMainThread(aEntry^.Thread);
  251. { is this a Synchronize or Queue entry? }
  252. if Assigned(aEntry^.SyncEvent) then begin
  253. RtlEventWaitFor(aEntry^.SyncEvent);
  254. if Assigned(aEntry^.Exception) then
  255. raise aEntry^.Exception;
  256. end;
  257. end;
  258. end;
  259. procedure TThread.InitSynchronizeEvent;
  260. begin
  261. if Assigned(FSynchronizeEntry) then
  262. Exit;
  263. New(FSynchronizeEntry);
  264. FillChar(FSynchronizeEntry^, SizeOf(TThreadQueueEntry), 0);
  265. FSynchronizeEntry^.Thread := Self;
  266. FSynchronizeEntry^.SyncEvent := RtlEventCreate;
  267. end;
  268. procedure TThread.DoneSynchronizeEvent;
  269. begin
  270. if not Assigned(FSynchronizeEntry) then
  271. Exit;
  272. RtlEventDestroy(FSynchronizeEntry^.SyncEvent);
  273. Dispose(FSynchronizeEntry);
  274. FSynchronizeEntry := Nil;
  275. end;
  276. class procedure TThread.Synchronize(AThread: TThread; AMethod: TThreadMethod);
  277. begin
  278. { ensure that we have a TThread instance }
  279. if not Assigned(AThread) then
  280. AThread := CurrentThread;
  281. { the Synchronize event is instantiated on demand }
  282. AThread.InitSynchronizeEvent;
  283. AThread.FSynchronizeEntry^.Exception := Nil;
  284. AThread.FSynchronizeEntry^.Method := AMethod;
  285. ThreadQueueAppend(AThread.FSynchronizeEntry);
  286. AThread.FSynchronizeEntry^.Method := Nil;
  287. AThread.FSynchronizeEntry^.Next := Nil;
  288. end;
  289. procedure TThread.Synchronize(AMethod: TThreadMethod);
  290. begin
  291. TThread.Synchronize(self,AMethod);
  292. end;
  293. Function PopThreadQueueHead : TThread.PThreadQueueEntry;
  294. begin
  295. Result:=ThreadQueueHead;
  296. if (Result<>Nil) then
  297. begin
  298. System.EnterCriticalSection(ThreadQueueLock);
  299. try
  300. Result:=ThreadQueueHead;
  301. if Result<>Nil then
  302. ThreadQueueHead:=ThreadQueueHead^.Next;
  303. if Not Assigned(ThreadQueueHead) then
  304. ThreadQueueTail := Nil;
  305. finally
  306. System.LeaveCriticalSection(ThreadQueueLock);
  307. end;
  308. end;
  309. end;
  310. function CheckSynchronize(timeout : longint=0) : boolean;
  311. { assumes being called from GUI thread }
  312. var
  313. ExceptObj: Exception;
  314. tmpentry: TThread.PThreadQueueEntry;
  315. begin
  316. result:=false;
  317. { first sanity check }
  318. if Not IsMultiThread then
  319. Exit
  320. { second sanity check }
  321. else if GetCurrentThreadID<>MainThreadID then
  322. raise EThread.CreateFmt(SCheckSynchronizeError,[GetCurrentThreadID]);
  323. if timeout>0 then
  324. RtlEventWaitFor(SynchronizeTimeoutEvent,timeout)
  325. else
  326. RtlEventResetEvent(SynchronizeTimeoutEvent);
  327. tmpentry := PopThreadQueueHead;
  328. while Assigned(tmpentry) do
  329. begin
  330. { step 2: execute the method }
  331. exceptobj := Nil;
  332. try
  333. ExecuteThreadQueueEntry(tmpentry);
  334. except
  335. exceptobj := Exception(AcquireExceptionObject);
  336. end;
  337. { step 3: error handling and cleanup }
  338. if Assigned(tmpentry^.SyncEvent) then
  339. begin
  340. { for Synchronize entries we pass back the Exception and trigger
  341. the event that Synchronize waits in }
  342. tmpentry^.Exception := exceptobj;
  343. RtlEventSetEvent(tmpentry^.SyncEvent)
  344. end
  345. else
  346. begin
  347. { for Queue entries we dispose the entry and raise the exception }
  348. Dispose(tmpentry);
  349. if Assigned(exceptobj) then
  350. raise exceptobj;
  351. end;
  352. tmpentry := PopThreadQueueHead;
  353. end;
  354. end;
  355. class function TThread.GetCurrentThread: TThread;
  356. begin
  357. { if this is the first time GetCurrentThread is called for an external thread
  358. we need to create a corresponding TExternalThread instance }
  359. Result := CurrentThreadVar;
  360. if not Assigned(Result) then begin
  361. Result := TExternalThread.Create;
  362. CurrentThreadVar := Result;
  363. end;
  364. end;
  365. class function TThread.GetIsSingleProcessor: Boolean;
  366. begin
  367. Result := FProcessorCount <= 1;
  368. end;
  369. procedure TThread.Queue(aMethod: TThreadMethod);
  370. begin
  371. Queue(Self, aMethod);
  372. end;
  373. class procedure TThread.Queue(aThread: TThread; aMethod: TThreadMethod); static;
  374. var
  375. queueentry: PThreadQueueEntry;
  376. begin
  377. { ensure that we have a valid TThread instance }
  378. if not Assigned(aThread) then
  379. aThread := CurrentThread;
  380. New(queueentry);
  381. FillChar(queueentry^, SizeOf(TThreadQueueEntry), 0);
  382. queueentry^.Thread := aThread;
  383. queueentry^.Method := aMethod;
  384. { the queueentry is freed by CheckSynchronize (or by RemoveQueuedEvents) }
  385. ThreadQueueAppend(queueentry);
  386. end;
  387. class procedure TThread.RemoveQueuedEvents(aThread: TThread; aMethod: TThreadMethod);
  388. var
  389. entry, tmpentry, lastentry: PThreadQueueEntry;
  390. begin
  391. { anything to do at all? }
  392. if not Assigned(aThread) or not Assigned(aMethod) then
  393. Exit;
  394. System.EnterCriticalSection(ThreadQueueLock);
  395. try
  396. lastentry := Nil;
  397. entry := ThreadQueueHead;
  398. while Assigned(entry) do begin
  399. { first check for the thread }
  400. if Assigned(aThread) and (entry^.Thread <> aThread) then begin
  401. lastentry := entry;
  402. entry := entry^.Next;
  403. Continue;
  404. end;
  405. { then check for the method }
  406. if entry^.Method <> aMethod then begin
  407. lastentry := entry;
  408. entry := entry^.Next;
  409. Continue;
  410. end;
  411. { skip entries added by Synchronize }
  412. if Assigned(entry^.SyncEvent) then begin
  413. lastentry := entry;
  414. entry := entry^.Next;
  415. Continue;
  416. end;
  417. { ok, we need to remove this entry }
  418. tmpentry := entry;
  419. if Assigned(lastentry) then
  420. lastentry^.Next := entry^.Next;
  421. entry := entry^.Next;
  422. if ThreadQueueHead = tmpentry then
  423. ThreadQueueHead := entry;
  424. if ThreadQueueTail = tmpentry then
  425. ThreadQueueTail := lastentry;
  426. { only dispose events added by Queue }
  427. if not Assigned(tmpentry^.SyncEvent) then
  428. Dispose(tmpentry);
  429. end;
  430. finally
  431. System.LeaveCriticalSection(ThreadQueueLock);
  432. end;
  433. end;
  434. class procedure TThread.RemoveQueuedEvents(aMethod: TThreadMethod);
  435. begin
  436. RemoveQueuedEvents(Nil, aMethod);
  437. end;
  438. class procedure TThread.RemoveQueuedEvents(aThread: TThread);
  439. begin
  440. RemoveQueuedEvents(aThread, Nil);
  441. end;
  442. class function TThread.CheckTerminated: Boolean;
  443. begin
  444. { this method only works with threads created by TThread, so we can make a
  445. shortcut here }
  446. if not Assigned(CurrentThreadVar) then
  447. raise EThreadExternalException.Create(SThreadExternal);
  448. Result := CurrentThreadVar.FTerminated;
  449. end;
  450. class procedure TThread.SetReturnValue(aValue: Integer);
  451. begin
  452. { this method only works with threads created by TThread, so we can make a
  453. shortcut here }
  454. if not Assigned(CurrentThreadVar) then
  455. raise EThreadExternalException.Create(SThreadExternal);
  456. CurrentThreadVar.FReturnValue := aValue;
  457. end;
  458. class function TThread.CreateAnonymousThread(aProc: TProcedure): TThread;
  459. begin
  460. if not Assigned(aProc) then
  461. raise Exception.Create(SNoProcGiven);
  462. Result := TAnonymousThread.Create(aProc);
  463. end;
  464. {$ifdef THREADNAME_IS_ANSISTRING}
  465. { the platform implements the AnsiString variant and the UnicodeString variant
  466. simply calls the AnsiString variant }
  467. class procedure TThread.NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID);
  468. begin
  469. NameThreadForDebugging(AnsiString(aThreadName), aThreadID);
  470. end;
  471. {$ifndef HAS_TTHREAD_NAMETHREADFORDEBUGGING}
  472. class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
  473. begin
  474. { empty }
  475. end;
  476. {$endif}
  477. {$else}
  478. {$ifndef HAS_TTHREAD_NAMETHREADFORDEBUGGING}
  479. { the platform implements the UnicodeString variant and the AnsiString variant
  480. simply calls the UnicodeString variant }
  481. class procedure TThread.NameThreadForDebugging(aThreadName: UnicodeString; aThreadID: TThreadID);
  482. begin
  483. { empty }
  484. end;
  485. {$endif}
  486. class procedure TThread.NameThreadForDebugging(aThreadName: AnsiString; aThreadID: TThreadID);
  487. begin
  488. NameThreadForDebugging(UnicodeString(aThreadName), aThreadID);
  489. end;
  490. {$endif}
  491. class procedure TThread.Yield;
  492. begin
  493. ThreadSwitch;
  494. end;
  495. class procedure TThread.Sleep(aMilliseconds: Cardinal);
  496. begin
  497. SysUtils.Sleep(aMilliseconds);
  498. end;
  499. class procedure TThread.SpinWait(aIterations: LongWord);
  500. var
  501. i: LongWord;
  502. begin
  503. { yes, it's just a simple busy wait to burn some cpu cycles... and as the job
  504. of this loop is to burn CPU cycles we switch off any optimizations that
  505. could interfere with this (e.g. loop unrolling) }
  506. { Do *NOT* do $PUSH, $OPTIMIZATIONS OFF, <code>, $POP because optimization is
  507. not a local switch, which means $PUSH/POP doesn't affect it, so that turns
  508. off *ALL* optimizations for code below this point. Thanks to this we shipped
  509. large parts of the classes unit with optimizations off between 2012-12-27
  510. and 2014-06-06.
  511. Instead, use a global var for the spinlock, because that is always handled
  512. as volatile, so the access won't be optimized away by the compiler. (KB) }
  513. for i:=1 to aIterations do
  514. begin
  515. Inc(SpinWaitDummy); // SpinWaitDummy *MUST* be global
  516. end;
  517. end;
  518. {$ifndef HAS_TTHREAD_GETSYSTEMTIMES}
  519. class procedure TThread.GetSystemTimes(out aSystemTimes: TSystemTimes);
  520. begin
  521. { by default we just return a zeroed out record }
  522. FillChar(aSystemTimes, SizeOf(aSystemTimes), 0);
  523. end;
  524. {$endif}
  525. class function TThread.GetTickCount: LongWord;
  526. begin
  527. Result := SysUtils.GetTickCount;
  528. end;
  529. class function TThread.GetTickCount64: QWord;
  530. begin
  531. Result := SysUtils.GetTickCount64;
  532. end;
  533. { TSimpleThread allows objects to create a threading method without defining
  534. a new thread class }
  535. Type
  536. TSimpleThread = class(TThread)
  537. private
  538. FExecuteMethod: TThreadExecuteHandler;
  539. protected
  540. procedure Execute; override;
  541. public
  542. constructor Create(ExecuteMethod: TThreadExecuteHandler; AOnterminate : TNotifyEvent);
  543. end;
  544. TSimpleStatusThread = class(TThread)
  545. private
  546. FExecuteMethod: TThreadExecuteStatusHandler;
  547. FStatus : String;
  548. FOnStatus : TThreadStatusNotifyEvent;
  549. protected
  550. procedure Execute; override;
  551. Procedure DoStatus;
  552. Procedure SetStatus(Const AStatus : String);
  553. public
  554. constructor Create(ExecuteMethod: TThreadExecuteStatusHandler; AOnStatus : TThreadStatusNotifyEvent; AOnterminate : TNotifyEvent);
  555. end;
  556. TSimpleProcThread = class(TThread)
  557. private
  558. FExecuteMethod: TThreadExecuteCallBack;
  559. FCallOnTerminate : TNotifyCallBack;
  560. FData : Pointer;
  561. protected
  562. Procedure TerminateCallBack(Sender : TObject);
  563. procedure Execute; override;
  564. public
  565. constructor Create(ExecuteMethod: TThreadExecuteCallBack; AData : Pointer; AOnterminate : TNotifyCallBack);
  566. end;
  567. TSimpleStatusProcThread = class(TThread)
  568. private
  569. FExecuteMethod: TThreadExecuteStatusCallBack;
  570. FCallOnTerminate : TNotifyCallBack;
  571. FStatus : String;
  572. FOnStatus : TThreadStatusNotifyCallBack;
  573. FData : Pointer;
  574. protected
  575. procedure Execute; override;
  576. Procedure DoStatus;
  577. Procedure SetStatus(Const AStatus : String);
  578. Procedure TerminateCallBack(Sender : TObject);
  579. public
  580. constructor Create(ExecuteMethod: TThreadExecuteStatusCallBack; AData : Pointer; AOnStatus : TThreadStatusNotifyCallBack; AOnterminate : TNotifyCallBack);
  581. end;
  582. { TSimpleThread }
  583. constructor TSimpleThread.Create(ExecuteMethod: TThreadExecuteHandler; AOnTerminate: TNotifyEvent);
  584. begin
  585. FExecuteMethod := ExecuteMethod;
  586. OnTerminate := AOnTerminate;
  587. inherited Create(False);
  588. end;
  589. procedure TSimpleThread.Execute;
  590. begin
  591. FreeOnTerminate := True;
  592. FExecuteMethod;
  593. end;
  594. { TSimpleStatusThread }
  595. constructor TSimpleStatusThread.Create(ExecuteMethod: TThreadExecuteStatusHandler;AOnStatus : TThreadStatusNotifyEvent; AOnTerminate: TNotifyEvent);
  596. begin
  597. FExecuteMethod := ExecuteMethod;
  598. OnTerminate := AOnTerminate;
  599. FOnStatus:=AOnStatus;
  600. FStatus:='';
  601. inherited Create(False);
  602. end;
  603. procedure TSimpleStatusThread.Execute;
  604. begin
  605. FreeOnTerminate := True;
  606. FExecuteMethod(@SetStatus);
  607. end;
  608. procedure TSimpleStatusThread.SetStatus(Const AStatus : String);
  609. begin
  610. If (AStatus=FStatus) then
  611. exit;
  612. FStatus:=AStatus;
  613. If Assigned(FOnStatus) then
  614. Synchronize(@DoStatus);
  615. end;
  616. procedure TSimpleStatusThread.DoStatus;
  617. begin
  618. FOnStatus(Self,FStatus);
  619. end;
  620. { TSimpleProcThread }
  621. constructor TSimpleProcThread.Create(ExecuteMethod: TThreadExecuteCallBack; AData : Pointer; AOnTerminate: TNotifyCallBack);
  622. begin
  623. FExecuteMethod := ExecuteMethod;
  624. FCallOnTerminate := AOnTerminate;
  625. FData:=AData;
  626. If Assigned(FCallOnTerminate) then
  627. OnTerminate:=@TerminateCallBack;
  628. inherited Create(False);
  629. end;
  630. procedure TSimpleProcThread.Execute;
  631. begin
  632. FreeOnTerminate := True;
  633. FExecuteMethod(FData);
  634. end;
  635. procedure TSimpleProcThread.TerminateCallBack(Sender : TObject);
  636. begin
  637. if Assigned(FCallOnTerminate) then
  638. FCallOnTerminate(Sender,FData);
  639. end;
  640. { TSimpleStatusProcThread }
  641. constructor TSimpleStatusProcThread.Create(ExecuteMethod: TThreadExecuteStatusCallback; AData : Pointer; AOnStatus : TThreadStatusNotifyCallBack; AOnTerminate: TNotifyCallBack);
  642. begin
  643. FExecuteMethod := ExecuteMethod;
  644. FCallOnTerminate := AOnTerminate;
  645. FData:=AData;
  646. If Assigned(FCallOnTerminate) then
  647. OnTerminate:=@TerminateCallBack;
  648. FOnStatus:=AOnStatus;
  649. FStatus:='';
  650. inherited Create(False);
  651. end;
  652. procedure TSimpleStatusProcThread.Execute;
  653. begin
  654. FreeOnTerminate := True;
  655. FExecuteMethod(FData,@SetStatus);
  656. end;
  657. procedure TSimpleStatusProcThread.SetStatus(Const AStatus : String);
  658. begin
  659. If (AStatus=FStatus) then
  660. exit;
  661. FStatus:=AStatus;
  662. If Assigned(FOnStatus) then
  663. Synchronize(@DoStatus);
  664. end;
  665. procedure TSimpleStatusProcThread.DoStatus;
  666. begin
  667. FOnStatus(Self,FData,FStatus);
  668. end;
  669. procedure TSimpleStatusProcThread.TerminateCallBack(Sender : TObject);
  670. begin
  671. if Assigned(FCallOnTerminate) then
  672. FCallOnTerminate(Sender,FData);
  673. end;
  674. Class Function TThread.ExecuteInThread(AMethod : TThreadExecuteHandler; AOnTerminate : TNotifyEvent = Nil) : TThread;
  675. begin
  676. Result:=TSimpleThread.Create(AMethod,AOnTerminate);
  677. end;
  678. Class Function TThread.ExecuteInThread(AMethod : TThreadExecuteCallback; AData : Pointer; AOnTerminate : TNotifyCallback = Nil) : TThread;
  679. begin
  680. Result:=TSimpleProcThread.Create(AMethod,AData,AOnTerminate);
  681. end;
  682. Class Function TThread.ExecuteInThread(AMethod : TThreadExecuteStatusHandler; AOnStatus : TThreadStatusNotifyEvent; AOnTerminate : TNotifyEvent = Nil) : TThread;
  683. begin
  684. If Not Assigned(AOnStatus) then
  685. Raise EThread.Create(SErrStatusCallBackRequired);
  686. Result:=TSimpleStatusThread.Create(AMethod,AOnStatus,AOnTerminate);
  687. end;
  688. Class Function TThread.ExecuteInThread(AMethod : TThreadExecuteStatusCallback; AOnStatus : TThreadStatusNotifyCallback;AData : Pointer = Nil; AOnTerminate : TNotifyCallBack = Nil) : TThread;
  689. begin
  690. If Not Assigned(AOnStatus) then
  691. Raise EThread.Create(SErrStatusCallBackRequired);
  692. Result:=TSimpleStatusProcThread.Create(AMethod,AData,AOnStatus,AOnTerminate);
  693. end;
  694. { TPersistent implementation }
  695. {$i persist.inc }
  696. {$i sllist.inc}
  697. {$i resref.inc}
  698. { TComponent implementation }
  699. {$i compon.inc}
  700. { TBasicAction implementation }
  701. {$i action.inc}
  702. { TDataModule implementation }
  703. {$i dm.inc}
  704. { Class and component registration routines }
  705. {$I cregist.inc}
  706. { Interface related stuff }
  707. {$I intf.inc}
  708. {**********************************************************************
  709. * Miscellaneous procedures and functions *
  710. **********************************************************************}
  711. function ExtractStrings(Separators, WhiteSpace: TSysCharSet; Content: PChar; Strings: TStrings; AddEmptyStrings : Boolean = False): Integer;
  712. var
  713. b, c : pchar;
  714. procedure SkipWhitespace;
  715. begin
  716. while (c^ in Whitespace) do
  717. inc (c);
  718. end;
  719. procedure AddString;
  720. var
  721. l : integer;
  722. s : string;
  723. begin
  724. l := c-b;
  725. if (l > 0) or AddEmptyStrings then
  726. begin
  727. if assigned(Strings) then
  728. begin
  729. setlength(s, l);
  730. if l>0 then
  731. move (b^, s[1],l*SizeOf(char));
  732. Strings.Add (s);
  733. end;
  734. inc (result);
  735. end;
  736. end;
  737. var
  738. quoted : char;
  739. begin
  740. result := 0;
  741. c := Content;
  742. Quoted := #0;
  743. Separators := Separators + [#13, #10] - ['''','"'];
  744. SkipWhitespace;
  745. b := c;
  746. while (c^ <> #0) do
  747. begin
  748. if (c^ = Quoted) then
  749. begin
  750. if ((c+1)^ = Quoted) then
  751. inc (c)
  752. else
  753. Quoted := #0
  754. end
  755. else if (Quoted = #0) and (c^ in ['''','"']) then
  756. Quoted := c^;
  757. if (Quoted = #0) and (c^ in Separators) then
  758. begin
  759. AddString;
  760. inc (c);
  761. SkipWhitespace;
  762. b := c;
  763. end
  764. else
  765. inc (c);
  766. end;
  767. if (c <> b) then
  768. AddString;
  769. end;
  770. { Point and rectangle constructors }
  771. function Point(AX, AY: Integer): TPoint;
  772. begin
  773. with Result do
  774. begin
  775. X := AX;
  776. Y := AY;
  777. end;
  778. end;
  779. function SmallPoint(AX, AY: SmallInt): TSmallPoint;
  780. begin
  781. with Result do
  782. begin
  783. X := AX;
  784. Y := AY;
  785. end;
  786. end;
  787. function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  788. begin
  789. with Result do
  790. begin
  791. Left := ALeft;
  792. Top := ATop;
  793. Right := ARight;
  794. Bottom := ABottom;
  795. end;
  796. end;
  797. function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
  798. begin
  799. with Result do
  800. begin
  801. Left := ALeft;
  802. Top := ATop;
  803. Right := ALeft + AWidth;
  804. Bottom := ATop + AHeight;
  805. end;
  806. end;
  807. function PointsEqual(const P1, P2: TPoint): Boolean; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
  808. begin
  809. { lazy, but should work }
  810. result:=QWord(P1)=QWord(P2);
  811. end;
  812. function PointsEqual(const P1, P2: TSmallPoint): Boolean; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
  813. begin
  814. { lazy, but should work }
  815. result:=DWord(P1)=DWord(P2);
  816. end;
  817. function InvalidPoint(X, Y: Integer): Boolean;
  818. begin
  819. result:=(X=-1) and (Y=-1);
  820. end;
  821. function InvalidPoint(const At: TPoint): Boolean;
  822. begin
  823. result:=(At.x=-1) and (At.y=-1);
  824. end;
  825. function InvalidPoint(const At: TSmallPoint): Boolean;
  826. begin
  827. result:=(At.x=-1) and (At.y=-1);
  828. end;
  829. { Object filing routines }
  830. var
  831. IntConstList: TThreadList;
  832. type
  833. TIntConst = class
  834. IntegerType: PTypeInfo; // The integer type RTTI pointer
  835. IdentToIntFn: TIdentToInt; // Identifier to Integer conversion
  836. IntToIdentFn: TIntToIdent; // Integer to Identifier conversion
  837. constructor Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
  838. AIntToIdent: TIntToIdent);
  839. end;
  840. constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
  841. AIntToIdent: TIntToIdent);
  842. begin
  843. IntegerType := AIntegerType;
  844. IdentToIntFn := AIdentToInt;
  845. IntToIdentFn := AIntToIdent;
  846. end;
  847. procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToIntFn: TIdentToInt;
  848. IntToIdentFn: TIntToIdent);
  849. begin
  850. IntConstList.Add(TIntConst.Create(IntegerType, IdentToIntFn, IntToIdentFn));
  851. end;
  852. function FindIntToIdent(AIntegerType: Pointer): TIntToIdent;
  853. var
  854. i: Integer;
  855. begin
  856. with IntConstList.LockList do
  857. try
  858. for i := 0 to Count - 1 do
  859. if TIntConst(Items[i]).IntegerType = AIntegerType then
  860. exit(TIntConst(Items[i]).IntToIdentFn);
  861. Result := nil;
  862. finally
  863. IntConstList.UnlockList;
  864. end;
  865. end;
  866. function FindIdentToInt(AIntegerType: Pointer): TIdentToInt;
  867. var
  868. i: Integer;
  869. begin
  870. with IntConstList.LockList do
  871. try
  872. for i := 0 to Count - 1 do
  873. with TIntConst(Items[I]) do
  874. if TIntConst(Items[I]).IntegerType = AIntegerType then
  875. exit(IdentToIntFn);
  876. Result := nil;
  877. finally
  878. IntConstList.UnlockList;
  879. end;
  880. end;
  881. function IdentToInt(const Ident: String; out Int: LongInt;
  882. const Map: array of TIdentMapEntry): Boolean;
  883. var
  884. i: Integer;
  885. begin
  886. for i := Low(Map) to High(Map) do
  887. if CompareText(Map[i].Name, Ident) = 0 then
  888. begin
  889. Int := Map[i].Value;
  890. exit(True);
  891. end;
  892. Result := False;
  893. end;
  894. function IntToIdent(Int: LongInt; var Ident: String;
  895. const Map: array of TIdentMapEntry): Boolean;
  896. var
  897. i: Integer;
  898. begin
  899. for i := Low(Map) to High(Map) do
  900. if Map[i].Value = Int then
  901. begin
  902. Ident := Map[i].Name;
  903. exit(True);
  904. end;
  905. Result := False;
  906. end;
  907. function GlobalIdentToInt(const Ident: String; var Int: LongInt):boolean;
  908. var
  909. i : Integer;
  910. begin
  911. with IntConstList.LockList do
  912. try
  913. for i := 0 to Count - 1 do
  914. if TIntConst(Items[I]).IdentToIntFn(Ident, Int) then
  915. Exit(True);
  916. Result := false;
  917. finally
  918. IntConstList.UnlockList;
  919. end;
  920. end;
  921. { TPropFixup }
  922. // Tainted. TPropFixup is being removed.
  923. Type
  924. TInitHandler = Class(TObject)
  925. AHandler : TInitComponentHandler;
  926. AClass : TComponentClass;
  927. end;
  928. {$ifndef i8086}
  929. type
  930. TCodePtrList = TList;
  931. {$endif i8086}
  932. Var
  933. InitHandlerList : TList;
  934. FindGlobalComponentList : TCodePtrList;
  935. procedure RegisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent);
  936. begin
  937. if not(assigned(FindGlobalComponentList)) then
  938. FindGlobalComponentList:=TCodePtrList.Create;
  939. if FindGlobalComponentList.IndexOf(CodePointer(AFindGlobalComponent))<0 then
  940. FindGlobalComponentList.Add(CodePointer(AFindGlobalComponent));
  941. end;
  942. procedure UnregisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent);
  943. begin
  944. if assigned(FindGlobalComponentList) then
  945. FindGlobalComponentList.Remove(CodePointer(AFindGlobalComponent));
  946. end;
  947. function FindGlobalComponent(const Name: string): TComponent;
  948. var
  949. i : sizeint;
  950. begin
  951. FindGlobalComponent:=nil;
  952. if assigned(FindGlobalComponentList) then
  953. begin
  954. for i:=FindGlobalComponentList.Count-1 downto 0 do
  955. begin
  956. FindGlobalComponent:=TFindGlobalComponent(FindGlobalComponentList[i])(name);
  957. if assigned(FindGlobalComponent) then
  958. break;
  959. end;
  960. end;
  961. end;
  962. procedure RegisterInitComponentHandler(ComponentClass: TComponentClass; Handler: TInitComponentHandler);
  963. Var
  964. I : Integer;
  965. H: TInitHandler;
  966. begin
  967. If (InitHandlerList=Nil) then
  968. InitHandlerList:=TList.Create;
  969. H:=TInitHandler.Create;
  970. H.Aclass:=ComponentClass;
  971. H.AHandler:=Handler;
  972. try
  973. With InitHandlerList do
  974. begin
  975. I:=0;
  976. While (I<Count) and not H.AClass.InheritsFrom(TInitHandler(Items[I]).AClass) do
  977. Inc(I);
  978. { override? }
  979. if (I<Count) and (TInitHandler(Items[I]).AClass=H.AClass) then
  980. begin
  981. TInitHandler(Items[I]).AHandler:=Handler;
  982. H.Free;
  983. end
  984. else
  985. InitHandlerList.Insert(I,H);
  986. end;
  987. except
  988. H.Free;
  989. raise;
  990. end;
  991. end;
  992. { all targets should at least include the sysres.inc dummy in the system unit to compile this }
  993. function CreateComponentfromRes(const res : string;Inst : THandle;var Component : TComponent) : Boolean;
  994. var
  995. ResStream : TResourceStream;
  996. begin
  997. result:=true;
  998. if Inst=0 then
  999. Inst:=HInstance;
  1000. try
  1001. ResStream:=TResourceStream.Create(Inst,res,RT_RCDATA);
  1002. try
  1003. Component:=ResStream.ReadComponent(Component);
  1004. finally
  1005. ResStream.Free;
  1006. end;
  1007. except
  1008. on EResNotFound do
  1009. result:=false;
  1010. end;
  1011. end;
  1012. function DefaultInitHandler(Instance: TComponent; RootAncestor: TClass): Boolean;
  1013. function doinit(_class : TClass) : boolean;
  1014. begin
  1015. result:=false;
  1016. if (_class.ClassType=TComponent) or (_class.ClassType=RootAncestor) then
  1017. exit;
  1018. result:=doinit(_class.ClassParent);
  1019. result:=CreateComponentfromRes(_class.ClassName,0,Instance) or result;
  1020. end;
  1021. begin
  1022. GlobalNameSpace.BeginWrite;
  1023. try
  1024. result:=doinit(Instance.ClassType);
  1025. finally
  1026. GlobalNameSpace.EndWrite;
  1027. end;
  1028. end;
  1029. function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
  1030. Var
  1031. I : Integer;
  1032. begin
  1033. I:=0;
  1034. if not Assigned(InitHandlerList) then begin
  1035. Result := True;
  1036. Exit;
  1037. end;
  1038. Result:=False;
  1039. With InitHandlerList do
  1040. begin
  1041. I:=0;
  1042. // Instance is the normally the lowest one, so that one should be used when searching.
  1043. While Not result and (I<Count) do
  1044. begin
  1045. If (Instance.InheritsFrom(TInitHandler(Items[i]).AClass)) then
  1046. Result:=TInitHandler(Items[i]).AHandler(Instance,RootAncestor);
  1047. Inc(I);
  1048. end;
  1049. end;
  1050. end;
  1051. function InitComponentRes(const ResName: String; Instance: TComponent): Boolean;
  1052. begin
  1053. Result:=ReadComponentRes(ResName,Instance)=Instance;
  1054. end;
  1055. function SysReadComponentRes(HInstance : THandle; const ResName: String; Instance: TComponent): TComponent;
  1056. Var
  1057. H : TFPResourceHandle;
  1058. begin
  1059. { Windows unit also has a FindResource function, use the one from
  1060. system unit here. }
  1061. H:=system.FindResource(HInstance,ResName,RT_RCDATA);
  1062. if (PtrInt(H)=0) then
  1063. Result:=Nil
  1064. else
  1065. With TResourceStream.Create(HInstance,ResName,RT_RCDATA) do
  1066. try
  1067. Result:=ReadComponent(Instance);
  1068. Finally
  1069. Free;
  1070. end;
  1071. end;
  1072. function ReadComponentRes(const ResName: String; Instance: TComponent): TComponent;
  1073. begin
  1074. Result:=SysReadComponentRes(Hinstance,Resname,Instance);
  1075. end;
  1076. function ReadComponentResEx(HInstance: THandle; const ResName: String): TComponent;
  1077. begin
  1078. Result:=SysReadComponentRes(Hinstance,ResName,Nil);
  1079. end;
  1080. function ReadComponentResFile(const FileName: String; Instance: TComponent): TComponent;
  1081. var
  1082. FileStream: TStream;
  1083. begin
  1084. FileStream := TFileStream.Create(FileName, fmOpenRead {!!!:or fmShareDenyWrite});
  1085. try
  1086. Result := FileStream.ReadComponentRes(Instance);
  1087. finally
  1088. FileStream.Free;
  1089. end;
  1090. end;
  1091. procedure WriteComponentResFile(const FileName: String; Instance: TComponent);
  1092. var
  1093. FileStream: TStream;
  1094. begin
  1095. FileStream := TFileStream.Create(FileName, fmCreate);
  1096. try
  1097. FileStream.WriteComponentRes(Instance.ClassName, Instance);
  1098. finally
  1099. FileStream.Free;
  1100. end;
  1101. end;
  1102. Function FindNestedComponent(Root : TComponent; APath : String; CStyle : Boolean = True) : TComponent;
  1103. Function GetNextName : String; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  1104. Var
  1105. P : Integer;
  1106. CM : Boolean;
  1107. begin
  1108. P:=Pos('.',APath);
  1109. CM:=False;
  1110. If (P=0) then
  1111. begin
  1112. If CStyle then
  1113. begin
  1114. P:=Pos('->',APath);
  1115. CM:=P<>0;
  1116. end;
  1117. If (P=0) Then
  1118. P:=Length(APath)+1;
  1119. end;
  1120. Result:=Copy(APath,1,P-1);
  1121. Delete(APath,1,P+Ord(CM));
  1122. end;
  1123. Var
  1124. C : TComponent;
  1125. S : String;
  1126. begin
  1127. If (APath='') then
  1128. Result:=Nil
  1129. else
  1130. begin
  1131. Result:=Root;
  1132. While (APath<>'') And (Result<>Nil) do
  1133. begin
  1134. C:=Result;
  1135. S:=Uppercase(GetNextName);
  1136. Result:=C.FindComponent(S);
  1137. If (Result=Nil) And (S='OWNER') then
  1138. Result:=C;
  1139. end;
  1140. end;
  1141. end;
  1142. threadvar
  1143. GlobalLoaded, GlobalLists: TFpList;
  1144. procedure BeginGlobalLoading;
  1145. begin
  1146. if not Assigned(GlobalLists) then
  1147. GlobalLists := TFpList.Create;
  1148. GlobalLists.Add(GlobalLoaded);
  1149. GlobalLoaded := TFpList.Create;
  1150. end;
  1151. { Notify all global components that they have been loaded completely }
  1152. procedure NotifyGlobalLoading;
  1153. var
  1154. i: Integer;
  1155. begin
  1156. for i := 0 to GlobalLoaded.Count - 1 do
  1157. TComponent(GlobalLoaded[i]).Loaded;
  1158. end;
  1159. procedure EndGlobalLoading;
  1160. begin
  1161. { Free the memory occupied by BeginGlobalLoading }
  1162. GlobalLoaded.Free;
  1163. GlobalLoaded := TFpList(GlobalLists.Last);
  1164. GlobalLists.Delete(GlobalLists.Count - 1);
  1165. if GlobalLists.Count = 0 then
  1166. begin
  1167. GlobalLists.Free;
  1168. GlobalLists := nil;
  1169. end;
  1170. end;
  1171. function CollectionsEqual(C1, C2: TCollection): Boolean;
  1172. begin
  1173. // !!!: Implement this
  1174. CollectionsEqual:=false;
  1175. end;
  1176. function CollectionsEqual(C1, C2: TCollection; Owner1, Owner2: TComponent): Boolean;
  1177. procedure stream_collection(s : tstream;c : tcollection;o : tcomponent);
  1178. var
  1179. w : twriter;
  1180. begin
  1181. w:=twriter.create(s,4096);
  1182. try
  1183. w.root:=o;
  1184. w.flookuproot:=o;
  1185. w.writecollection(c);
  1186. finally
  1187. w.free;
  1188. end;
  1189. end;
  1190. var
  1191. s1,s2 : tmemorystream;
  1192. begin
  1193. result:=false;
  1194. if (c1.classtype<>c2.classtype) or
  1195. (c1.count<>c2.count) then
  1196. exit;
  1197. if c1.count = 0 then
  1198. begin
  1199. result:= true;
  1200. exit;
  1201. end;
  1202. s1:=tmemorystream.create;
  1203. try
  1204. s2:=tmemorystream.create;
  1205. try
  1206. stream_collection(s1,c1,owner1);
  1207. stream_collection(s2,c2,owner2);
  1208. result:=(s1.size=s2.size) and (CompareChar(s1.memory^,s2.memory^,s1.size)=0);
  1209. finally
  1210. s2.free;
  1211. end;
  1212. finally
  1213. s1.free;
  1214. end;
  1215. end;
  1216. { Object conversion routines }
  1217. type
  1218. CharToOrdFuncty = Function(var charpo: Pointer): Cardinal;
  1219. function CharToOrd(var P: Pointer): Cardinal;
  1220. begin
  1221. result:= ord(pchar(P)^);
  1222. inc(pchar(P));
  1223. end;
  1224. function WideCharToOrd(var P: Pointer): Cardinal;
  1225. begin
  1226. result:= ord(pwidechar(P)^);
  1227. inc(pwidechar(P));
  1228. end;
  1229. function Utf8ToOrd(var P:Pointer): Cardinal;
  1230. begin
  1231. // Should also check for illegal utf8 combinations
  1232. Result := Ord(PChar(P)^);
  1233. Inc(P);
  1234. if (Result and $80) <> 0 then
  1235. if (Ord(Result) and %11100000) = %11000000 then begin
  1236. Result := ((Result and %00011111) shl 6)
  1237. or (ord(PChar(P)^) and %00111111);
  1238. Inc(P);
  1239. end else if (Ord(Result) and %11110000) = %11100000 then begin
  1240. Result := ((Result and %00011111) shl 12)
  1241. or ((ord(PChar(P)^) and %00111111) shl 6)
  1242. or (ord((PChar(P)+1)^) and %00111111);
  1243. Inc(P,2);
  1244. end else begin
  1245. Result := ((ord(Result) and %00011111) shl 18)
  1246. or ((ord(PChar(P)^) and %00111111) shl 12)
  1247. or ((ord((PChar(P)+1)^) and %00111111) shl 6)
  1248. or (ord((PChar(P)+2)^) and %00111111);
  1249. Inc(P,3);
  1250. end;
  1251. end;
  1252. procedure ObjectBinaryToText(Input, Output: TStream; Encoding: TObjectTextEncoding);
  1253. procedure OutStr(s: String);
  1254. begin
  1255. if Length(s) > 0 then
  1256. Output.Write(s[1], Length(s));
  1257. end;
  1258. procedure OutLn(s: String);
  1259. begin
  1260. OutStr(s + LineEnding);
  1261. end;
  1262. procedure Outchars(P, LastP : Pointer; CharToOrdFunc: CharToOrdFuncty;
  1263. UseBytes: boolean = false);
  1264. var
  1265. res, NewStr: String;
  1266. w: Cardinal;
  1267. InString, NewInString: Boolean;
  1268. begin
  1269. if p = nil then begin
  1270. res:= '''''';
  1271. end
  1272. else
  1273. begin
  1274. res := '';
  1275. InString := False;
  1276. while P < LastP do
  1277. begin
  1278. NewInString := InString;
  1279. w := CharToOrdfunc(P);
  1280. if w = ord('''') then
  1281. begin //quote char
  1282. if not InString then
  1283. NewInString := True;
  1284. NewStr := '''''';
  1285. end
  1286. else if (Ord(w) >= 32) and ((Ord(w) < 127) or (UseBytes and (Ord(w)<256))) then
  1287. begin //printable ascii or bytes
  1288. if not InString then
  1289. NewInString := True;
  1290. NewStr := char(w);
  1291. end
  1292. else
  1293. begin //ascii control chars, non ascii
  1294. if InString then
  1295. NewInString := False;
  1296. NewStr := '#' + IntToStr(w);
  1297. end;
  1298. if NewInString <> InString then
  1299. begin
  1300. NewStr := '''' + NewStr;
  1301. InString := NewInString;
  1302. end;
  1303. res := res + NewStr;
  1304. end;
  1305. if InString then
  1306. res := res + '''';
  1307. end;
  1308. OutStr(res);
  1309. end;
  1310. procedure OutString(s: String);
  1311. begin
  1312. OutChars(Pointer(S),PChar(S)+Length(S),@CharToOrd,Encoding=oteLFM);
  1313. end;
  1314. procedure OutWString(W: WideString);
  1315. begin
  1316. OutChars(Pointer(W),pwidechar(W)+Length(W),@WideCharToOrd);
  1317. end;
  1318. procedure OutUString(W: UnicodeString);
  1319. begin
  1320. OutChars(Pointer(W),pwidechar(W)+Length(W),@WideCharToOrd);
  1321. end;
  1322. procedure OutUtf8Str(s: String);
  1323. begin
  1324. if Encoding=oteLFM then
  1325. OutChars(Pointer(S),PChar(S)+Length(S),@CharToOrd)
  1326. else
  1327. OutChars(Pointer(S),PChar(S)+Length(S),@Utf8ToOrd);
  1328. end;
  1329. function ReadWord : word; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
  1330. begin
  1331. Result:=Input.ReadWord;
  1332. Result:=LEtoN(Result);
  1333. end;
  1334. function ReadDWord : longword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
  1335. begin
  1336. Result:=Input.ReadDWord;
  1337. Result:=LEtoN(Result);
  1338. end;
  1339. function ReadQWord : qword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
  1340. begin
  1341. Input.ReadBuffer(Result,sizeof(Result));
  1342. Result:=LEtoN(Result);
  1343. end;
  1344. {$ifndef FPUNONE}
  1345. {$IFNDEF FPC_HAS_TYPE_EXTENDED}
  1346. function ExtendedToDouble(e : pointer) : double;
  1347. var mant : qword;
  1348. exp : smallint;
  1349. sign : boolean;
  1350. d : qword;
  1351. begin
  1352. move(pbyte(e)[0],mant,8); //mantissa : bytes 0..7
  1353. move(pbyte(e)[8],exp,2); //exponent and sign: bytes 8..9
  1354. mant:=LEtoN(mant);
  1355. exp:=LetoN(word(exp));
  1356. sign:=(exp and $8000)<>0;
  1357. if sign then exp:=exp and $7FFF;
  1358. case exp of
  1359. 0 : mant:=0; //if denormalized, value is too small for double,
  1360. //so it's always zero
  1361. $7FFF : exp:=2047 //either infinity or NaN
  1362. else
  1363. begin
  1364. dec(exp,16383-1023);
  1365. if (exp>=-51) and (exp<=0) then //can be denormalized
  1366. begin
  1367. mant:=mant shr (-exp);
  1368. exp:=0;
  1369. end
  1370. else
  1371. if (exp<-51) or (exp>2046) then //exponent too large.
  1372. begin
  1373. Result:=0;
  1374. exit;
  1375. end
  1376. else //normalized value
  1377. mant:=mant shl 1; //hide most significant bit
  1378. end;
  1379. end;
  1380. d:=word(exp);
  1381. d:=d shl 52;
  1382. mant:=mant shr 12;
  1383. d:=d or mant;
  1384. if sign then d:=d or $8000000000000000;
  1385. Result:=pdouble(@d)^;
  1386. end;
  1387. {$ENDIF}
  1388. {$endif}
  1389. function ReadInt(ValueType: TValueType): Int64;
  1390. begin
  1391. case ValueType of
  1392. vaInt8: Result := ShortInt(Input.ReadByte);
  1393. vaInt16: Result := SmallInt(ReadWord);
  1394. vaInt32: Result := LongInt(ReadDWord);
  1395. vaInt64: Result := Int64(ReadQWord);
  1396. end;
  1397. end;
  1398. function ReadInt: Int64;
  1399. begin
  1400. Result := ReadInt(TValueType(Input.ReadByte));
  1401. end;
  1402. {$ifndef FPUNONE}
  1403. function ReadExtended : extended;
  1404. {$IFNDEF FPC_HAS_TYPE_EXTENDED}
  1405. var ext : array[0..9] of byte;
  1406. {$ENDIF}
  1407. begin
  1408. {$IFNDEF FPC_HAS_TYPE_EXTENDED}
  1409. Input.ReadBuffer(ext[0],10);
  1410. Result:=ExtendedToDouble(@(ext[0]));
  1411. {$ELSE}
  1412. Input.ReadBuffer(Result,sizeof(Result));
  1413. {$ENDIF}
  1414. end;
  1415. {$endif}
  1416. function ReadSStr: String;
  1417. var
  1418. len: Byte;
  1419. begin
  1420. len := Input.ReadByte;
  1421. SetLength(Result, len);
  1422. if (len > 0) then
  1423. Input.ReadBuffer(Result[1], len);
  1424. end;
  1425. function ReadLStr: String;
  1426. var
  1427. len: DWord;
  1428. begin
  1429. len := ReadDWord;
  1430. SetLength(Result, len);
  1431. if (len > 0) then
  1432. Input.ReadBuffer(Result[1], len);
  1433. end;
  1434. function ReadWStr: WideString;
  1435. var
  1436. len: DWord;
  1437. {$IFDEF ENDIAN_BIG}
  1438. i : integer;
  1439. {$ENDIF}
  1440. begin
  1441. len := ReadDWord;
  1442. SetLength(Result, len);
  1443. if (len > 0) then
  1444. begin
  1445. Input.ReadBuffer(Pointer(@Result[1])^, len*2);
  1446. {$IFDEF ENDIAN_BIG}
  1447. for i:=1 to len do
  1448. Result[i]:=widechar(SwapEndian(word(Result[i])));
  1449. {$ENDIF}
  1450. end;
  1451. end;
  1452. function ReadUStr: UnicodeString;
  1453. var
  1454. len: DWord;
  1455. {$IFDEF ENDIAN_BIG}
  1456. i : integer;
  1457. {$ENDIF}
  1458. begin
  1459. len := ReadDWord;
  1460. SetLength(Result, len);
  1461. if (len > 0) then
  1462. begin
  1463. Input.ReadBuffer(Pointer(@Result[1])^, len*2);
  1464. {$IFDEF ENDIAN_BIG}
  1465. for i:=1 to len do
  1466. Result[i]:=widechar(SwapEndian(word(Result[i])));
  1467. {$ENDIF}
  1468. end;
  1469. end;
  1470. procedure ReadPropList(indent: String);
  1471. procedure ProcessValue(ValueType: TValueType; Indent: String);
  1472. procedure ProcessBinary;
  1473. var
  1474. ToDo, DoNow, i: LongInt;
  1475. lbuf: array[0..31] of Byte;
  1476. s: String;
  1477. begin
  1478. ToDo := ReadDWord;
  1479. OutLn('{');
  1480. while ToDo > 0 do begin
  1481. DoNow := ToDo;
  1482. if DoNow > 32 then DoNow := 32;
  1483. Dec(ToDo, DoNow);
  1484. s := Indent + ' ';
  1485. Input.ReadBuffer(lbuf, DoNow);
  1486. for i := 0 to DoNow - 1 do
  1487. s := s + IntToHex(lbuf[i], 2);
  1488. OutLn(s);
  1489. end;
  1490. OutLn(indent + '}');
  1491. end;
  1492. var
  1493. s: String;
  1494. { len: LongInt; }
  1495. IsFirst: Boolean;
  1496. {$ifndef FPUNONE}
  1497. ext: Extended;
  1498. {$endif}
  1499. begin
  1500. case ValueType of
  1501. vaList: begin
  1502. OutStr('(');
  1503. IsFirst := True;
  1504. while True do begin
  1505. ValueType := TValueType(Input.ReadByte);
  1506. if ValueType = vaNull then break;
  1507. if IsFirst then begin
  1508. OutLn('');
  1509. IsFirst := False;
  1510. end;
  1511. OutStr(Indent + ' ');
  1512. ProcessValue(ValueType, Indent + ' ');
  1513. end;
  1514. OutLn(Indent + ')');
  1515. end;
  1516. vaInt8: OutLn(IntToStr(ShortInt(Input.ReadByte)));
  1517. vaInt16: OutLn( IntToStr(SmallInt(ReadWord)));
  1518. vaInt32: OutLn(IntToStr(LongInt(ReadDWord)));
  1519. vaInt64: OutLn(IntToStr(Int64(ReadQWord)));
  1520. {$ifndef FPUNONE}
  1521. vaExtended: begin
  1522. ext:=ReadExtended;
  1523. Str(ext,S);// Do not use localized strings.
  1524. OutLn(S);
  1525. end;
  1526. {$endif}
  1527. vaString: begin
  1528. OutString(ReadSStr);
  1529. OutLn('');
  1530. end;
  1531. vaIdent: OutLn(ReadSStr);
  1532. vaFalse: OutLn('False');
  1533. vaTrue: OutLn('True');
  1534. vaBinary: ProcessBinary;
  1535. vaSet: begin
  1536. OutStr('[');
  1537. IsFirst := True;
  1538. while True do begin
  1539. s := ReadSStr;
  1540. if Length(s) = 0 then break;
  1541. if not IsFirst then OutStr(', ');
  1542. IsFirst := False;
  1543. OutStr(s);
  1544. end;
  1545. OutLn(']');
  1546. end;
  1547. vaLString:
  1548. begin
  1549. OutString(ReadLStr);
  1550. OutLn('');
  1551. end;
  1552. vaWString:
  1553. begin
  1554. OutWString(ReadWStr);
  1555. OutLn('');
  1556. end;
  1557. vaUString:
  1558. begin
  1559. OutWString(ReadWStr);
  1560. OutLn('');
  1561. end;
  1562. vaNil:
  1563. OutLn('nil');
  1564. vaCollection: begin
  1565. OutStr('<');
  1566. while Input.ReadByte <> 0 do begin
  1567. OutLn(Indent);
  1568. Input.Seek(-1, soFromCurrent);
  1569. OutStr(indent + ' item');
  1570. ValueType := TValueType(Input.ReadByte);
  1571. if ValueType <> vaList then
  1572. OutStr('[' + IntToStr(ReadInt(ValueType)) + ']');
  1573. OutLn('');
  1574. ReadPropList(indent + ' ');
  1575. OutStr(indent + ' end');
  1576. end;
  1577. OutLn('>');
  1578. end;
  1579. {vaSingle: begin OutLn('!!Single!!'); exit end;
  1580. vaCurrency: begin OutLn('!!Currency!!'); exit end;
  1581. vaDate: begin OutLn('!!Date!!'); exit end;}
  1582. vaUTF8String: begin
  1583. OutUtf8Str(ReadLStr);
  1584. OutLn('');
  1585. end;
  1586. else
  1587. Raise EReadError.CreateFmt(SErrInvalidPropertyType,[Ord(ValueType)]);
  1588. end;
  1589. end;
  1590. begin
  1591. while Input.ReadByte <> 0 do begin
  1592. Input.Seek(-1, soFromCurrent);
  1593. OutStr(indent + ReadSStr + ' = ');
  1594. ProcessValue(TValueType(Input.ReadByte), Indent);
  1595. end;
  1596. end;
  1597. procedure ReadObject(indent: String);
  1598. var
  1599. b: Byte;
  1600. ObjClassName, ObjName: String;
  1601. ChildPos: LongInt;
  1602. begin
  1603. // Check for FilerFlags
  1604. b := Input.ReadByte;
  1605. if (b and $f0) = $f0 then begin
  1606. if (b and 2) <> 0 then ChildPos := ReadInt;
  1607. end else begin
  1608. b := 0;
  1609. Input.Seek(-1, soFromCurrent);
  1610. end;
  1611. ObjClassName := ReadSStr;
  1612. ObjName := ReadSStr;
  1613. OutStr(Indent);
  1614. if (b and 1) <> 0 then OutStr('inherited')
  1615. else
  1616. if (b and 4) <> 0 then OutStr('inline')
  1617. else OutStr('object');
  1618. OutStr(' ');
  1619. if ObjName <> '' then
  1620. OutStr(ObjName + ': ');
  1621. OutStr(ObjClassName);
  1622. if (b and 2) <> 0 then OutStr('[' + IntToStr(ChildPos) + ']');
  1623. OutLn('');
  1624. ReadPropList(indent + ' ');
  1625. while Input.ReadByte <> 0 do begin
  1626. Input.Seek(-1, soFromCurrent);
  1627. ReadObject(indent + ' ');
  1628. end;
  1629. OutLn(indent + 'end');
  1630. end;
  1631. type
  1632. PLongWord = ^LongWord;
  1633. const
  1634. signature: PChar = 'TPF0';
  1635. begin
  1636. if Input.ReadDWord <> PLongWord(Pointer(signature))^ then
  1637. raise EReadError.Create('Illegal stream image' {###SInvalidImage});
  1638. ReadObject('');
  1639. end;
  1640. procedure ObjectBinaryToText(Input, Output: TStream);
  1641. begin
  1642. ObjectBinaryToText(Input,Output,oteDFM);
  1643. end;
  1644. procedure ObjectTextToBinary(Input, Output: TStream);
  1645. var
  1646. parser: TParser;
  1647. procedure WriteWord(w : word); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
  1648. begin
  1649. w:=NtoLE(w);
  1650. Output.WriteWord(w);
  1651. end;
  1652. procedure WriteDWord(lw : longword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
  1653. begin
  1654. lw:=NtoLE(lw);
  1655. Output.WriteDWord(lw);
  1656. end;
  1657. procedure WriteQWord(qw : qword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
  1658. begin
  1659. qw:=NtoLE(qw);
  1660. Output.WriteBuffer(qw,sizeof(qword));
  1661. end;
  1662. {$ifndef FPUNONE}
  1663. {$IFNDEF FPC_HAS_TYPE_EXTENDED}
  1664. procedure DoubleToExtended(d : double; e : pointer);
  1665. var mant : qword;
  1666. exp : smallint;
  1667. sign : boolean;
  1668. begin
  1669. mant:=(qword(d) and $000FFFFFFFFFFFFF) shl 12;
  1670. exp :=(qword(d) shr 52) and $7FF;
  1671. sign:=(qword(d) and $8000000000000000)<>0;
  1672. case exp of
  1673. 0 : begin
  1674. if mant<>0 then //denormalized value: hidden bit is 0. normalize it
  1675. begin
  1676. exp:=16383-1022;
  1677. while (mant and $8000000000000000)=0 do
  1678. begin
  1679. dec(exp);
  1680. mant:=mant shl 1;
  1681. end;
  1682. dec(exp); //don't shift, most significant bit is not hidden in extended
  1683. end;
  1684. end;
  1685. 2047 : exp:=$7FFF //either infinity or NaN
  1686. else
  1687. begin
  1688. inc(exp,16383-1023);
  1689. mant:=(mant shr 1) or $8000000000000000; //unhide hidden bit
  1690. end;
  1691. end;
  1692. if sign then exp:=exp or $8000;
  1693. mant:=NtoLE(mant);
  1694. exp:=NtoLE(word(exp));
  1695. move(mant,pbyte(e)[0],8); //mantissa : bytes 0..7
  1696. move(exp,pbyte(e)[8],2); //exponent and sign: bytes 8..9
  1697. end;
  1698. {$ENDIF}
  1699. procedure WriteExtended(e : extended);
  1700. {$IFNDEF FPC_HAS_TYPE_EXTENDED}
  1701. var ext : array[0..9] of byte;
  1702. {$ENDIF}
  1703. begin
  1704. {$IFNDEF FPC_HAS_TYPE_EXTENDED}
  1705. DoubleToExtended(e,@(ext[0]));
  1706. Output.WriteBuffer(ext[0],10);
  1707. {$ELSE}
  1708. Output.WriteBuffer(e,sizeof(e));
  1709. {$ENDIF}
  1710. end;
  1711. {$endif}
  1712. procedure WriteString(s: String);
  1713. var size : byte;
  1714. begin
  1715. if length(s)>255 then size:=255
  1716. else size:=length(s);
  1717. Output.WriteByte(size);
  1718. if Length(s) > 0 then
  1719. Output.WriteBuffer(s[1], size);
  1720. end;
  1721. procedure WriteLString(Const s: String);
  1722. begin
  1723. WriteDWord(Length(s));
  1724. if Length(s) > 0 then
  1725. Output.WriteBuffer(s[1], Length(s));
  1726. end;
  1727. procedure WriteWString(Const s: WideString);
  1728. var len : longword;
  1729. {$IFDEF ENDIAN_BIG}
  1730. i : integer;
  1731. ws : widestring;
  1732. {$ENDIF}
  1733. begin
  1734. len:=Length(s);
  1735. WriteDWord(len);
  1736. if len > 0 then
  1737. begin
  1738. {$IFDEF ENDIAN_BIG}
  1739. setlength(ws,len);
  1740. for i:=1 to len do
  1741. ws[i]:=widechar(SwapEndian(word(s[i])));
  1742. Output.WriteBuffer(ws[1], len*sizeof(widechar));
  1743. {$ELSE}
  1744. Output.WriteBuffer(s[1], len*sizeof(widechar));
  1745. {$ENDIF}
  1746. end;
  1747. end;
  1748. procedure WriteInteger(value: Int64);
  1749. begin
  1750. if (value >= -128) and (value <= 127) then begin
  1751. Output.WriteByte(Ord(vaInt8));
  1752. Output.WriteByte(byte(value));
  1753. end else if (value >= -32768) and (value <= 32767) then begin
  1754. Output.WriteByte(Ord(vaInt16));
  1755. WriteWord(word(value));
  1756. end else if (value >= -2147483648) and (value <= 2147483647) then begin
  1757. Output.WriteByte(Ord(vaInt32));
  1758. WriteDWord(longword(value));
  1759. end else begin
  1760. Output.WriteByte(ord(vaInt64));
  1761. WriteQWord(qword(value));
  1762. end;
  1763. end;
  1764. procedure ProcessWideString(const left : widestring);
  1765. var ws : widestring;
  1766. begin
  1767. ws:=left+parser.TokenWideString;
  1768. while parser.NextToken = '+' do
  1769. begin
  1770. parser.NextToken; // Get next string fragment
  1771. if not (parser.Token in [toString,toWString]) then
  1772. parser.CheckToken(toWString);
  1773. ws:=ws+parser.TokenWideString;
  1774. end;
  1775. Output.WriteByte(Ord(vaWstring));
  1776. WriteWString(ws);
  1777. end;
  1778. procedure ProcessProperty; forward;
  1779. procedure ProcessValue;
  1780. var
  1781. {$ifndef FPUNONE}
  1782. flt: Extended;
  1783. {$endif}
  1784. s: String;
  1785. stream: TMemoryStream;
  1786. begin
  1787. case parser.Token of
  1788. toInteger:
  1789. begin
  1790. WriteInteger(parser.TokenInt);
  1791. parser.NextToken;
  1792. end;
  1793. {$ifndef FPUNONE}
  1794. toFloat:
  1795. begin
  1796. Output.WriteByte(Ord(vaExtended));
  1797. flt := Parser.TokenFloat;
  1798. WriteExtended(flt);
  1799. parser.NextToken;
  1800. end;
  1801. {$endif}
  1802. toString:
  1803. begin
  1804. s := parser.TokenString;
  1805. while parser.NextToken = '+' do
  1806. begin
  1807. parser.NextToken; // Get next string fragment
  1808. case parser.Token of
  1809. toString : s:=s+parser.TokenString;
  1810. toWString : begin
  1811. ProcessWideString(WideString(s));
  1812. exit;
  1813. end
  1814. else parser.CheckToken(toString);
  1815. end;
  1816. end;
  1817. if (length(S)>255) then
  1818. begin
  1819. Output.WriteByte(Ord(vaLString));
  1820. WriteLString(S);
  1821. end
  1822. else
  1823. begin
  1824. Output.WriteByte(Ord(vaString));
  1825. WriteString(s);
  1826. end;
  1827. end;
  1828. toWString:
  1829. ProcessWideString('');
  1830. toSymbol:
  1831. begin
  1832. if CompareText(parser.TokenString, 'True') = 0 then
  1833. Output.WriteByte(Ord(vaTrue))
  1834. else if CompareText(parser.TokenString, 'False') = 0 then
  1835. Output.WriteByte(Ord(vaFalse))
  1836. else if CompareText(parser.TokenString, 'nil') = 0 then
  1837. Output.WriteByte(Ord(vaNil))
  1838. else
  1839. begin
  1840. Output.WriteByte(Ord(vaIdent));
  1841. WriteString(parser.TokenComponentIdent);
  1842. end;
  1843. Parser.NextToken;
  1844. end;
  1845. // Set
  1846. '[':
  1847. begin
  1848. parser.NextToken;
  1849. Output.WriteByte(Ord(vaSet));
  1850. if parser.Token <> ']' then
  1851. while True do
  1852. begin
  1853. parser.CheckToken(toSymbol);
  1854. WriteString(parser.TokenString);
  1855. parser.NextToken;
  1856. if parser.Token = ']' then
  1857. break;
  1858. parser.CheckToken(',');
  1859. parser.NextToken;
  1860. end;
  1861. Output.WriteByte(0);
  1862. parser.NextToken;
  1863. end;
  1864. // List
  1865. '(':
  1866. begin
  1867. parser.NextToken;
  1868. Output.WriteByte(Ord(vaList));
  1869. while parser.Token <> ')' do
  1870. ProcessValue;
  1871. Output.WriteByte(0);
  1872. parser.NextToken;
  1873. end;
  1874. // Collection
  1875. '<':
  1876. begin
  1877. parser.NextToken;
  1878. Output.WriteByte(Ord(vaCollection));
  1879. while parser.Token <> '>' do
  1880. begin
  1881. parser.CheckTokenSymbol('item');
  1882. parser.NextToken;
  1883. // ConvertOrder
  1884. Output.WriteByte(Ord(vaList));
  1885. while not parser.TokenSymbolIs('end') do
  1886. ProcessProperty;
  1887. parser.NextToken; // Skip 'end'
  1888. Output.WriteByte(0);
  1889. end;
  1890. Output.WriteByte(0);
  1891. parser.NextToken;
  1892. end;
  1893. // Binary data
  1894. '{':
  1895. begin
  1896. Output.WriteByte(Ord(vaBinary));
  1897. stream := TMemoryStream.Create;
  1898. try
  1899. parser.HexToBinary(stream);
  1900. WriteDWord(stream.Size);
  1901. Output.WriteBuffer(Stream.Memory^, stream.Size);
  1902. finally
  1903. stream.Free;
  1904. end;
  1905. parser.NextToken;
  1906. end;
  1907. else
  1908. parser.Error(SInvalidProperty);
  1909. end;
  1910. end;
  1911. procedure ProcessProperty;
  1912. var
  1913. name: String;
  1914. begin
  1915. // Get name of property
  1916. parser.CheckToken(toSymbol);
  1917. name := parser.TokenString;
  1918. while True do begin
  1919. parser.NextToken;
  1920. if parser.Token <> '.' then break;
  1921. parser.NextToken;
  1922. parser.CheckToken(toSymbol);
  1923. name := name + '.' + parser.TokenString;
  1924. end;
  1925. WriteString(name);
  1926. parser.CheckToken('=');
  1927. parser.NextToken;
  1928. ProcessValue;
  1929. end;
  1930. procedure ProcessObject;
  1931. var
  1932. Flags: Byte;
  1933. ObjectName, ObjectType: String;
  1934. ChildPos: Integer;
  1935. begin
  1936. if parser.TokenSymbolIs('OBJECT') then
  1937. Flags :=0 { IsInherited := False }
  1938. else begin
  1939. if parser.TokenSymbolIs('INHERITED') then
  1940. Flags := 1 { IsInherited := True; }
  1941. else begin
  1942. parser.CheckTokenSymbol('INLINE');
  1943. Flags := 4;
  1944. end;
  1945. end;
  1946. parser.NextToken;
  1947. parser.CheckToken(toSymbol);
  1948. ObjectName := '';
  1949. ObjectType := parser.TokenString;
  1950. parser.NextToken;
  1951. if parser.Token = ':' then begin
  1952. parser.NextToken;
  1953. parser.CheckToken(toSymbol);
  1954. ObjectName := ObjectType;
  1955. ObjectType := parser.TokenString;
  1956. parser.NextToken;
  1957. if parser.Token = '[' then begin
  1958. parser.NextToken;
  1959. ChildPos := parser.TokenInt;
  1960. parser.NextToken;
  1961. parser.CheckToken(']');
  1962. parser.NextToken;
  1963. Flags := Flags or 2;
  1964. end;
  1965. end;
  1966. if Flags <> 0 then begin
  1967. Output.WriteByte($f0 or Flags);
  1968. if (Flags and 2) <> 0 then
  1969. WriteInteger(ChildPos);
  1970. end;
  1971. WriteString(ObjectType);
  1972. WriteString(ObjectName);
  1973. // Convert property list
  1974. while not (parser.TokenSymbolIs('END') or
  1975. parser.TokenSymbolIs('OBJECT') or
  1976. parser.TokenSymbolIs('INHERITED') or
  1977. parser.TokenSymbolIs('INLINE')) do
  1978. ProcessProperty;
  1979. Output.WriteByte(0); // Terminate property list
  1980. // Convert child objects
  1981. while not parser.TokenSymbolIs('END') do ProcessObject;
  1982. parser.NextToken; // Skip end token
  1983. Output.WriteByte(0); // Terminate property list
  1984. end;
  1985. const
  1986. signature: PChar = 'TPF0';
  1987. begin
  1988. parser := TParser.Create(Input);
  1989. try
  1990. Output.WriteBuffer(signature[0], 4);
  1991. ProcessObject;
  1992. finally
  1993. parser.Free;
  1994. end;
  1995. end;
  1996. procedure ObjectResourceToText(Input, Output: TStream);
  1997. begin
  1998. Input.ReadResHeader;
  1999. ObjectBinaryToText(Input, Output);
  2000. end;
  2001. procedure ObjectTextToResource(Input, Output: TStream);
  2002. var
  2003. StartPos, FixupInfo: LongInt;
  2004. parser: TParser;
  2005. name: String;
  2006. begin
  2007. // Get form type name
  2008. StartPos := Input.Position;
  2009. parser := TParser.Create(Input);
  2010. try
  2011. if not parser.TokenSymbolIs('OBJECT') then parser.CheckTokenSymbol('INHERITED');
  2012. parser.NextToken;
  2013. parser.CheckToken(toSymbol);
  2014. parser.NextToken;
  2015. parser.CheckToken(':');
  2016. parser.NextToken;
  2017. parser.CheckToken(toSymbol);
  2018. name := parser.TokenString;
  2019. finally
  2020. parser.Free;
  2021. Input.Position := StartPos;
  2022. end;
  2023. name := UpperCase(name);
  2024. Output.WriteResourceHeader(name,FixupInfo); // Write resource header
  2025. ObjectTextToBinary(Input, Output); // Convert the stuff!
  2026. Output.FixupResourceHeader(FixupInfo); // Insert real resource data size
  2027. end;
  2028. { Utility routines }
  2029. function LineStart(Buffer, BufPos: PChar): PChar;
  2030. begin
  2031. Result := BufPos;
  2032. while Result > Buffer do begin
  2033. Dec(Result);
  2034. if Result[0] = #10 then break;
  2035. end;
  2036. end;
  2037. procedure CommonInit;
  2038. begin
  2039. SynchronizeTimeoutEvent:=RtlEventCreate;
  2040. InitCriticalSection(ThreadQueueLock);
  2041. MainThreadID:=GetCurrentThreadID;
  2042. ExternalThreads := TThreadList.Create;
  2043. TThread.FProcessorCount := CPUCount;
  2044. InitCriticalsection(ResolveSection);
  2045. InitHandlerList:=Nil;
  2046. FindGlobalComponentList:=nil;
  2047. IntConstList := TThreadList.Create;
  2048. ClassList := TThreadList.Create;
  2049. ClassAliasList := TStringList.Create;
  2050. { on unix this maps to a simple rw synchornizer }
  2051. GlobalNameSpace := TMultiReadExclusiveWriteSynchronizer.Create;
  2052. RegisterInitComponentHandler(TComponent,@DefaultInitHandler);
  2053. end;
  2054. procedure CommonCleanup;
  2055. var
  2056. i: Integer;
  2057. tmpentry: TThread.PThreadQueueEntry;
  2058. begin
  2059. GlobalNameSpace.BeginWrite;
  2060. with IntConstList.LockList do
  2061. try
  2062. for i := 0 to Count - 1 do
  2063. TIntConst(Items[I]).Free;
  2064. finally
  2065. IntConstList.UnlockList;
  2066. end;
  2067. IntConstList.Free;
  2068. ClassList.Free;
  2069. ClassAliasList.Free;
  2070. RemoveFixupReferences(nil, '');
  2071. DoneCriticalsection(ResolveSection);
  2072. GlobalLists.Free;
  2073. ComponentPages.Free;
  2074. FreeAndNil(NeedResolving);
  2075. { GlobalNameSpace is an interface so this is enough }
  2076. GlobalNameSpace:=nil;
  2077. if (InitHandlerList<>Nil) then
  2078. for i := 0 to InitHandlerList.Count - 1 do
  2079. TInitHandler(InitHandlerList.Items[I]).Free;
  2080. InitHandlerList.Free;
  2081. InitHandlerList:=Nil;
  2082. FindGlobalComponentList.Free;
  2083. FindGlobalComponentList:=nil;
  2084. ExternalThreadsCleanup:=True;
  2085. with ExternalThreads.LockList do
  2086. try
  2087. for i := 0 to Count - 1 do
  2088. TThread(Items[i]).Free;
  2089. finally
  2090. ExternalThreads.UnlockList;
  2091. end;
  2092. FreeAndNil(ExternalThreads);
  2093. RtlEventDestroy(SynchronizeTimeoutEvent);
  2094. { clean up the queue, but keep in mind that the entries used for Synchronize
  2095. are owned by the corresponding TThread }
  2096. while Assigned(ThreadQueueHead) do begin
  2097. tmpentry := ThreadQueueHead;
  2098. ThreadQueueHead := tmpentry^.Next;
  2099. if not Assigned(tmpentry^.SyncEvent) then
  2100. Dispose(tmpentry);
  2101. end;
  2102. DoneCriticalSection(ThreadQueueLock);
  2103. end;
  2104. { TFiler implementation }
  2105. {$i filer.inc}
  2106. { TReader implementation }
  2107. {$i reader.inc}
  2108. { TWriter implementations }
  2109. {$i writer.inc}
  2110. {$i twriter.inc}