uathread.~pas

基于Midas 技术的多层应用开发包第二版（带开发文档）

{******************************************************************************************}
{                                                                                          }
{       Universal Agent on demond SDK                                                      }
{                                                                                          }
{                                                                                          }
{ COPYRIGHT                                                                                }
{ =========                                                                                }
{ The UA SDK (software) is Copyright (C) 2001-2003, by vinson zeng(曾胡龙).                }
{ All rights reserved.                                                                     }
{ The authors - vinson zeng (曾胡龙),                                                      }
{ exclusively own all copyrights to the Advanced Application                               }
{ Controls (AppControls) and all other products distributed by Utilmind Solutions(R).      }
{                                                                                          }
{ LIABILITY DISCLAIMER                                                                     }
{ ====================                                                                     }
{ THIS SOFTWARE IS DISTRIBUTED "AS IS" AND WITHOUT WARRANTIES AS TO PERFORMANCE            }
{ OF MERCHANTABILITY OR ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED.                 }
{ YOU USE IT AT YOUR OWN RISK. THE AUTHOR WILL NOT BE LIABLE FOR DATA LOSS,                }
{ DAMAGES, LOSS OF PROFITS OR ANY OTHER KIND OF LOSS WHILE USING OR MISUSING THIS SOFTWARE.}
{                                                                                          }
{ RESTRICTIONS                                                                             }
{ ============                                                                             }
{ You may not attempt to reverse compile, modify,                                          }
{ translate or disassemble the software in whole or in part.                               }
{ You may not remove or modify any copyright notice or the method by which                 }
{ it may be invoked.                                                                       }
{******************************************************************************************}

unit UAThread;

interface

uses
  Windows, Classes;

type

  TUACustomThread = class;
  { TUAEventThread }
  TUAEventThread = class
  private
    FHandle: THandle;
    FThreadID: THandle;
    FTerminated: Boolean;
    FSuspended: Boolean;
    FFreeOnTerminate: Boolean;
    FReturnValue: Integer;
    FRunning: Boolean;
    FMethod: TThreadMethod;
    FSynchronizeException: TObject;

    FOnExecute,
    FOnException,
    FOnTerminate: TNotifyEvent;

    // for internal use
    Owner: TUACustomThread;

    function  GetPriority: TThreadPriority;
    procedure SetPriority(Value: TThreadPriority);
    procedure SetSuspended(Value: Boolean);

    procedure CallTerminate;    
    procedure CallException;

  protected

    procedure DoTerminate; //virtual;
    procedure Execute; //virtual;
    procedure Synchronize(Method: TThreadMethod);
    property ReturnValue: Integer read FReturnValue write FReturnValue;
    property Terminated: Boolean read FTerminated;

    function CreateThread: TUAEventThread;
    function RecreateThread: TUAEventThread;

  public
    constructor Create(aOwner: TUACustomThread);
    destructor Destroy; override;
    procedure Resume;
    procedure Suspend;
    procedure Terminate;
    function WaitFor:Cardinal;

    property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
    property Handle: THandle read FHandle;
    property Priority: TThreadPriority read GetPriority write SetPriority;
    property Suspended: Boolean read FSuspended write SetSuspended;
    property ThreadID: THandle read FThreadID;

    property OnExecute: TNotifyEvent read FOnExecute write FOnExecute;
    property OnException: TNotifyEvent read FOnException write FOnException;
    property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;    
  end;

  { TUACustomThread }
  TUACustomThread = class(TComponent)
  private
    FThread: TUAEventThread;
    FDesignSuspended:Boolean;
    FHandleExceptions:Boolean;
    FFreeOwnerOnTerminate:Boolean;
    FWaitThread: Boolean;
    FWaitTimeout: Cardinal;    

    FOnWaitTimeoutExpired: TNotifyEvent;

    { for internal use }
    FSyncMethod: TNotifyEvent;
    FSyncParams: Pointer;

    procedure InternalSynchronization;

    function  GetPriority: TThreadPriority;
    procedure SetPriority(Value: TThreadPriority);
    function  GetSuspended: Boolean;
    procedure SetSuspended(Value: Boolean);
    function  GetRunning: Boolean;
    function  GetTerminated: Boolean;
    function  GetThreadID: THandle;

    function  GetOnException: TNotifyEvent;
    procedure SetOnException(Value: TNotifyEvent);
    function  GetOnExecute: TNotifyEvent;
    procedure SetOnExecute(Value: TNotifyEvent);
    function  GetOnTerminate: TNotifyEvent;
    procedure SetOnTerminate(Value: TNotifyEvent);

    function  GetHandle: THandle;
    function  GetReturnValue: Integer;
    procedure SetReturnValue(Value: Integer);
  protected
    procedure Loaded; override;
    procedure DoWaitTimeoutExpired; //virtual;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    { public methods and properties }
    function  Execute: Boolean; // virtual;
    procedure Synchronize(Method: TThreadMethod); //virtual;
    procedure SynchronizeEx(Method: TNotifyEvent; Params: Pointer); //virtual;
    procedure Suspend;
    procedure Resume;
    procedure Terminate(Imediately: Boolean); //virtual;
    function  WaitFor:Cardinal;

    property Handle: THandle read GetHandle;
    property Running: Boolean read GetRunning;
    property Terminated: Boolean read GetTerminated;
    property ThreadID: THandle read GetThreadID;
    property ReturnValue: Integer read GetReturnValue write SetReturnValue;
    property FreeOwnerOnTerminate: Boolean read FFreeOwnerOnTerminate write FFreeOwnerOnTerminate default False;

    // properties
    property HandleExceptions: Boolean read FHandleExceptions write FHandleExceptions default True;
    property Priority: TThreadPriority read GetPriority write SetPriority default tpNormal;
    property Suspended: Boolean read GetSuspended write SetSuspended default True;
    property WaitThread: Boolean read FWaitThread write FWaitThread default False;
    property WaitTimeout: Cardinal read FWaitTimeout write FWaitTimeout default 0;

    // events
    property OnException: TNotifyEvent read GetOnException write SetOnException;
    property OnExecute: TNotifyEvent read GetOnExecute write SetOnExecute;
    property OnTerminate: TNotifyEvent read GetOnTerminate write SetOnTerminate;
    property OnWaitTimeoutExpired: TNotifyEvent read FOnWaitTimeoutExpired write FOnWaitTimeoutExpired;
  end;

  { TUAThread }
  TUAThread = class(TUACustomThread)
  published
    property HandleExceptions;
    property Priority;
    property Suspended;
    property WaitThread;
    property WaitTimeout;

    property OnException;
    property OnExecute;
    property OnTerminate;
    property OnWaitTimeoutExpired;
  end;


  TUAThreadPool   = class(TComponent)
  private

  protected

  public


  published

  end;

  TUAThreadManager = class(TComponent)
  private


  protected


  public
    //procedure Spawn(Sender:TObject);


  published


  end;

implementation

uses Forms;

const
  CM_EXECPROC = $8FFF;
  CM_DESTROYWINDOW = $8FFE;

  Priorities: Array[TThreadPriority] of Integer =
   (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
    THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
    THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);

type
  PRaiseFrame = ^TRaiseFrame;
  TRaiseFrame = record
    NextRaise: PRaiseFrame;
    ExceptAddr: Pointer;
    ExceptObject: TObject;
    ExceptionRecord: PExceptionRecord;
  end;

var
  ThreadLock: TRTLCriticalSection;
  ThreadWindow: HWND;
  ThreadCount: Integer;


function ThreadWndProc(Window: HWND; Message, wParam, lParam: Longint): Longint; stdcall;
begin
  case Message of
    CM_EXECPROC:
      with TUAEventThread(lParam) do
       begin
        Result := 0;
        if not (csDestroying in Owner.ComponentState) then
         try
           FSynchronizeException := nil;
           FMethod;
         except
//没必要进行额外处理
//{$WARNINGS OFF}
//{$IFNDEF VER110}
           if RaiseList <> nil then
           begin
             FSynchronizeException := PRaiseFrame(RaiseList)^.ExceptObject;
             PRaiseFrame(RaiseList)^.ExceptObject := nil;
           end;
//{$ENDIF}
//{$WARNINGS ON}
         end;
       end;
    CM_DESTROYWINDOW:
      begin
        EnterCriticalSection(ThreadLock);
        try
          if (ThreadCount = 0) and (ThreadWindow <> 0) then
          begin
            DestroyWindow(ThreadWindow);
            ThreadWindow := 0;
          end;
        finally
          LeaveCriticalSection(ThreadLock);
        end;
        Result := 0;
      end;
  else
    Result := DefWindowProc(Window, Message, wParam, lParam);
  end;
end;

var
  ThreadWindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @ThreadWndProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'TUAThreadWindow');

procedure AddThread;

  function AllocateWindow: HWND;
  var
    TempClass: TWndClass;
    ClassRegistered: Boolean;
  begin
    ThreadWindowClass.hInstance := HInstance;
    ClassRegistered := GetClassInfo(HInstance, ThreadWindowClass.lpszClassName, TempClass);
    if not ClassRegistered or (TempClass.lpfnWndProc <> @ThreadWndProc) then
     begin
      if ClassRegistered then
        Windows.UnregisterClass(ThreadWindowClass.lpszClassName, HInstance);
      Windows.RegisterClass(ThreadWindowClass);
     end;
    Result := CreateWindow(ThreadWindowClass.lpszClassName, '', 0,
      0, 0, 0, 0, 0, 0, HInstance, nil);
  end;

begin
  EnterCriticalSection(ThreadLock);
  try
    if ThreadCount = 0 then
      ThreadWindow := AllocateWindow;
    Inc(ThreadCount);
  finally
    LeaveCriticalSection(ThreadLock);
  end;
end;

procedure RemoveThread;
begin
  EnterCriticalSection(ThreadLock);
  try
    Dec(ThreadCount);
    if ThreadCount = 0 then
      PostMessage(ThreadWindow, CM_DESTROYWINDOW, 0, 0);
  finally
    LeaveCriticalSection(ThreadLock);
  end;
end;

function ThreadProc(Thread: TUAEventThread): Integer;
var
  FreeThread: Boolean;
begin
  Thread.FRunning := True;
  try
    Thread.Execute;
  finally
    FreeThread := Thread.FFreeOnTerminate;
    Result := Thread.FReturnValue;
    Thread.FRunning := False;
    Thread.DoTerminate;
    if FreeThread then Thread.Free;
    EndThread(Result);
  end;
end;

{ TUAEventThread }
constructor TUAEventThread.Create(aOwner: TUACustomThread);
var
  Flags: DWORD;
begin
  inherited Create;
  Owner := aOwner;

  AddThread;
  
  FSuspended := True; 
  Flags := CREATE_SUSPENDED;

  FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), Flags, FThreadID);
end;

destructor TUAEventThread.Destroy;
begin
  if FRunning and not Suspended then
   begin