classes.inc 63 KB

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