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