idfiber.pas

photo.163.com 相册下载器 多线程下载

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  56066: IdFiber.pas
{
    Rev 1.3    6/11/2004 8:39:48 AM  DSiders
  Added "Do not Localize" comments.
}
{
{   Rev 1.2    2004.04.22 11:45:16 PM  czhower
{ Bug fixes
}
{
{   Rev 1.1    2004.02.09 9:16:34 PM  czhower
{ Updated to compile and match lib changes.
}
{
{   Rev 1.0    2004.02.03 12:38:48 AM  czhower
{ Move
}
{
{   Rev 1.8    2003.10.24 1:00:04 PM  czhower
{ Name change
}
{
{   Rev 1.7    2003.10.21 12:19:20 AM  czhower
{ TIdTask support and fiber bug fixes.
}
{
{   Rev 1.6    2003.10.19 2:50:38 PM  czhower
{ Fiber cleanup
}
{
{   Rev 1.5    2003.10.19 1:04:26 PM  czhower
{ Updates
}
{
{   Rev 1.3    2003.10.11 5:43:12 PM  czhower
{ Chained servers now functional.
}
{
{   Rev 1.2    2003.09.19 10:09:38 PM  czhower
{ Next stage of fiber support in servers.
}
{
{   Rev 1.1    2003.09.19 3:01:34 PM  czhower
{ Changed to emulate IdThreads Run behaviour
}
{
{   Rev 1.0    8/16/2003 11:09:14 AM  JPMugaas
{ Moved from Indy Core dir as part of package reorg
}
{
    Rev 1.25    7/2/2003 2:06:40 PM  BGooijen
  changed IdSupportsFibers to TIdFiberBase.HaveFiberSupport
}
{
    Rev 1.24    7/1/2003 8:34:14 PM  BGooijen
  Added function IdSupportsFibers
  Fiber-functions are now loaded on runtime
}
{
{   Rev 1.23    2003.06.30 7:33:50 PM  czhower
{ Fix to exception handling.
}
{
{   Rev 1.22    2003.06.30 6:52:20 PM  czhower
{ Exposed FiberWeaver has a property.
}
{
{   Rev 1.21    2003.06.03 11:05:02 PM  czhower
{ Modified ProcessInThisFiber to support error flag return.
}
{
{   Rev 1.20    2003.06.03 8:01:38 PM  czhower
{ Completed fiber exception handling.
}
{
{   Rev 1.19    2003.05.27 10:27:08 AM  czhower
{ Put back original exception handling.
}
{
    Rev 1.18    5/16/2003 3:48:24 PM  BGooijen
  Added FreeOnTerminate
}
{
    Rev 1.17    4/17/2003 7:40:00 PM  BGooijen
  Added AAutoStart for fibers
}
{
{   Rev 1.16    2003.04.17 7:44:56 PM  czhower
}
{
{   Rev 1.15    2003.04.14 10:54:08 AM  czhower
{ Fiber specific exceptions
}
{
{   Rev 1.14    2003.04.12 11:53:56 PM  czhower
{ Added DoExecute
}
{
    Rev 1.13    4/11/2003 1:46:58 PM  BGooijen
  added ProcessInThisFiber and WaitForFibers to TIdFiberWeaverBase
}
{
{   Rev 1.12    2003.04.10 11:21:42 PM  czhower
{ Yield support
}
{
{   Rev 1.9    2003.03.27 1:29:14 AM  czhower
{ Exception frame swapping.
}
{
{   Rev 1.7    3/22/2003 09:45:28 PM  JPMugaas
{ Now should compile under D4.
}
{
{   Rev 1.6    2003.03.13 1:25:18 PM  czhower
{ Moved check for parent fiber to SwitchTo
}
{
    Rev 1.5    3/13/2003 10:18:12 AM  BGooijen
  Server side fibers, bug fixes
}
{
{   Rev 1.4    2003.02.18 1:25:04 PM  czhower
{ Added exception if user tries to SwitchTo a completed fiber.
}
{
{   Rev 1.3    2003.01.17 2:32:12 PM  czhower
}
{
{   Rev 1.2    1-1-2003 16:25:10  BGooijen
{ The property ParentFiber can now be written to
{ Added class function TIdFiberBase.GetCurrentFiberBase, which returns the
{ current TIdFiber
}
{
{   Rev 1.1    12-28-2002 12:01:18  BGooijen
{ Made a public read only property: ParentFiber
}
{
{   Rev 1.0    11/13/2002 08:44:18 AM  JPMugaas
}
unit IdFiber;

interface

uses
  Classes,
  IdThreadSafe, IdBaseComponent, IdYarn, IdTask,
  SyncObjs, SysUtils,
  Windows;

type
  // TIdFiberBase is the base for both fiber types and contains
  // methods that are common to both and defines the general interface. All
  // references to fibers should generally use this base type.
  TIdFiberBase = class(TObject)
  protected
    FHandle: Pointer;
    FPriorFiber: TIdFiberBase;
    FName: string;
    FRaiseList: Pointer;
    // No descendants should ever call this. Its internal only
    // and should only be called after destruction or after the RaiseList has
    // been saved
    procedure SwitchToMeFrom(
      AFromFiber: TIdFiberBase
      );
  public
    constructor Create; reintroduce; virtual;
    procedure CheckRunnable; virtual;
    class function HaveFiberSupport: Boolean;
    procedure SwitchTo(AFiber: TIdFiberBase);
    //
    property Name: string read FName write FName;
    property PriorFiber: TIdFiberBase read FPriorFiber;
    property Handle: Pointer read FHandle;
  end;

  TIdFiber = class;
  TIdFiberRelinquishEvent = procedure(
    ASender: TIdFiber;
    AReschedule: Boolean
    ) of object;

  // TIdConvertedFiber is used to represent thread that have been converted to
  // fibers
  TIdConvertedFiber = class(TIdFiberBase)
  public
    constructor Create; override;
  end;

  // TIdFiber is the general purpose fiber. To implement fibers descend from
  // TIdFiber.
  TIdFiber = class(TIdFiberBase)
  protected
    FFatalException: Exception;
    FFatalExceptionOccurred: Boolean;
    FFinished: TIdThreadSafeBoolean;
    FFreeFatalException: Boolean;
    FFreeFiber: Boolean;
    FLoop: Boolean;
    FOnRelinquish: TIdFiberRelinquishEvent;
    FParentFiber: TIdFiberBase;
    FStarted: TIdThreadSafeBoolean;
    FStopped: TIdThreadSafeBoolean;
    FYarn: TIdYarn;
    //
    procedure AfterRun; virtual; //not abstract - otherwise it is required
    procedure BeforeRun; virtual; //not abstract - otherwise it is required
    function GetFinished: Boolean;
    function GetStarted: Boolean;
    function GetStopped: Boolean;
    procedure Execute;
    procedure Run; virtual; abstract;
    procedure SwitchToParent;
  public
    procedure CheckRunnable; override;
    constructor Create(
      AParentFiber: TIdFiberBase = nil;
      ALoop: Boolean = False;
      AStackSize: Integer = 0);
      reintroduce;
    destructor Destroy;
      override;
    procedure RaiseFatalException;
    // Relinquish is used when the fiber is stuck and cannot usefully do
    // anything. It will be removed from scheduling until something reschedules
    // it. This is different than yield.
    //
    // Relinquish is used with FiberWeavers to tell them that the fiber is done
    // or blocked. Something external such as more work, or completion of a task
    // must reschedule the fiber with the fiber weaver.
    procedure Relinquish;
    procedure SetRelinquishHandler(AValue: TIdFiberRelinquishEvent);
    procedure Stop; virtual;
    // Gives up execution time and tells scheduler to process next available
    // fiber.
    // For manual fibers (no weaver) relinquish is called
    // For woven fibers, the fiber is rescheduled and relinquished.
    procedure Yield;
    //
    property FatalExceptionOccurred: Boolean read FFatalExceptionOccurred;
    property Finished: Boolean read GetFinished;
    property Loop: Boolean read FLoop write FLoop;
    property Started: Boolean read GetStarted;
    property Stopped: Boolean read GetStopped;
    property ParentFiber: TIdFiberBase read FParentFiber write FParentFiber;
    property Yarn: TIdYarn read FYarn write FYarn;
  end;

  TIdFiberWithTask = class(TIdFiber)
  protected
    FTask: TIdTask;
  public
    procedure AfterRun; override;
    procedure BeforeRun; override;
    // Defaults because a bit crazy to create a non looped task
    constructor Create(
      AParentFiber: TIdFiberBase = nil;
      ATask: TIdTask = nil;
      AName: string = '';
      AStackSize: Integer = 0
      ); reintroduce;
    destructor Destroy;
      override;
    procedure Run;
      override;
    //
    // Must be writeable because tasks are often created after thread or
    // thread is pooled
    property Task: TIdTask read FTask write FTask;
  end;


implementation

uses
  IdGlobal, IdResourceStringsCore, IdExceptionCore, IdException;

var
  SwitchToFiber: function(lpFiber: Pointer): BOOL; stdcall = nil;
  CreateFiber: function(dwStackSize: DWORD; lpStartAddress: TFNFiberStartRoutine;
    lpParameter: Pointer): BOOL; stdcall=nil;
  DeleteFiber: function (lpFiber: Pointer): BOOL; stdcall = nil;
  ConvertThreadToFiber: function (lpParameter: Pointer): BOOL; stdcall = nil;

procedure LoadFiberFunctions;
var
  LKernel32Handle: THandle;
begin
  if TIdFiberBase.HaveFiberSupport then begin
    LKernel32Handle := GetModuleHandle(kernel32);
    SwitchToFiber := Getprocaddress(LKernel32Handle,'SwitchToFiber'); {do not localize}
    CreateFiber := Getprocaddress(LKernel32Handle,'CreateFiber'); {do not localize}
    DeleteFiber := Getprocaddress(LKernel32Handle,'DeleteFiber'); {do not localize}
    ConvertThreadToFiber := Getprocaddress(LKernel32Handle,'ConvertThreadToFiber'); {do not localize}
    if Assigned(@SwitchToFiber) and
     Assigned(@CreateFiber) and
     Assigned(@DeleteFiber) and
     Assigned(@ConvertThreadToFiber) then begin