classes.inc 63 KB

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