uathread.~pas

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

    Terminate;
    WaitFor;
   end;
  if FHandle <> 0 then CloseHandle(FHandle);
  inherited;
  RemoveThread;
end;

procedure TUAEventThread.DoTerminate;
begin
  if Assigned(FOnTerminate) then
    Synchronize(CallTerminate);
end;

function TUAEventThread.GetPriority: TThreadPriority;
var
  P: Integer;
  I: TThreadPriority;
begin
  P := GetThreadPriority(FHandle);
  Result := tpNormal;
  for I := Low(TThreadPriority) to High(TThreadPriority) do
    if Priorities[I] = P then
      Result := I;
end;

procedure TUAEventThread.SetPriority(Value: TThreadPriority);
begin
  SetThreadPriority(FHandle, Priorities[Value]);
end;

procedure TUAEventThread.Synchronize(Method: TThreadMethod);
begin
  FSynchronizeException := nil;
  FMethod := Method;
  SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self));
  if Assigned(FSynchronizeException) and not Owner.FHandleExceptions then
    raise FSynchronizeException;
end;

procedure TUAEventThread.SetSuspended(Value: Boolean);
begin
  if Value <> FSuspended then
   if Value then
     Suspend
   else
     Resume;
end;

procedure TUAEventThread.Suspend;
begin
  FSuspended := True;
  SuspendThread(FHandle);
end;

procedure TUAEventThread.Resume;
begin
  if ResumeThread(FHandle) = 1 then
    FSuspended := False;
end;

procedure TUAEventThread.Terminate;
begin
  FTerminated := True;
end;

function TUAEventThread.WaitFor:Cardinal;
var
  Msg: TMsg;
  H: THandle;
begin
  H := FHandle;
  if GetCurrentThreadID = MainThreadID then
    while MsgWaitForMultipleObjects(1, H, False, INFINITE, QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do
      PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
  else
    WaitForSingleObject(H, INFINITE);
  GetExitCodeThread(H, Result);
end;


function TUAEventThread.CreateThread: TUAEventThread;
begin
  Result := TUAEventThread.Create(Owner);
  try
    Result.Priority := Priority;
    Result.FOnTerminate := FOnTerminate;
    Result.FOnExecute := FOnExecute;
    Result.FOnException := FOnException;
  except
    Result.Free;
    raise;
  end;
end;               

function TUAEventThread.RecreateThread: TUAEventThread;
begin
  TerminateThread(Handle, 0);
  Result := CreateThread;
  Free;
end;

procedure TUAEventThread.CallTerminate;
var
  FreeOwnerOnTerminate: Boolean;
begin

  FreeOwnerOnTerminate := Owner.FFreeOwnerOnTerminate;

  if Assigned(FOnTerminate) and not (csDestroying in Owner.ComponentState) then
   if Owner.FHandleExceptions then
    try
      FOnTerminate(Owner);
    except
      if Assigned(FOnException) and not (csDestroying in Owner.ComponentState) then
        CallException;
    end
   else
     FOnTerminate(Owner);


  if FreeOwnerOnTerminate then
   with Owner do
    if Owner <> nil then
    begin
      FThread := CreateThread;
      Owner.Free;
    end;
    
end;

procedure TUAEventThread.CallException;
begin
  if not (csDestroying in Owner.ComponentState) and Assigned(FOnException) then
    FOnException(Owner);
end;

procedure TUAEventThread.Execute;
begin
  if Assigned(FOnExecute) and not (csDestroying in Owner.ComponentState) then
   if Owner.FHandleExceptions then
    try
      FOnExecute(Owner);  // ????
    except
      if Assigned(FOnException) and not (csDestroying in Owner.ComponentState) then
        Synchronize(CallException);
    end
   else
     FOnExecute(Owner);
end;


{ TUACustomThread }
constructor TUACustomThread.Create(aOwner: TComponent);
begin
  inherited;
  FDesignSuspended := True;
  FHandleExceptions := True;
  FThread := TUAEventThread.Create(Self);
end;

destructor TUACustomThread.Destroy;
begin
  if FThread.FRunning then Terminate(True);
  FThread.Free;
  inherited;
end;

procedure TUACustomThread.Loaded;
begin
  inherited;
  SetSuspended(FDesignSuspended);
end;

procedure TUACustomThread.DoWaitTimeoutExpired;
begin

  Terminate(True);
  if Assigned(FOnWaitTimeoutExpired) then
    //FOnWaitTimeoutExpired(Self);
    FOnWaitTimeoutExpired(Self)
  else
  begin
    //----- add by vinson zeng 2004-09-10...etc
    //在应用服务器中，如果有事务执行超时，必须写入日志，前提是没有上面的Event process
    

  end;

end;


function TUACustomThread.Execute: Boolean;
var
  CurrentThreadHandle: THandle;
  TempWaitTimeout, WaitResult: DWord;
begin
  Terminate(True);
  if FFreeOwnerOnTerminate then
    FThread.FreeOnTerminate := True;
  FThread.Resume;
  
  Result := True;
  if FWaitThread then
   begin
    CurrentThreadHandle := FThread.FHandle;
    if FWaitTimeout = 0 then
      TempWaitTimeout := INFINITE
    else
      TempWaitTimeout := FWaitTimeout;
    repeat
      WaitResult := MsgWaitForMultipleObjects(1, CurrentThreadHandle, False, TempWaitTimeout, QS_ALLINPUT);
      if WaitResult = WAIT_TIMEOUT then
       begin
        Terminate(True);
        if Assigned(FOnWaitTimeoutExpired) then
          FOnWaitTimeoutExpired(Self);
        Result := False;
        Exit;
       end;
      Application.ProcessMessages;
    until (WaitResult <> WAIT_OBJECT_0 + 1) or (csDestroying in ComponentState) or Application.Terminated;
   end;
   
end;

procedure TUACustomThread.Suspend;
begin
  FThread.Suspend;
end;

procedure TUACustomThread.Resume;
begin
  FThread.Resume;
end;

procedure TUACustomThread.Synchronize(Method: TThreadMethod);
begin
  if not (csDestroying in Owner.ComponentState) then
    FThread.Synchronize(Method);
end;

procedure TUACustomThread.InternalSynchronization;
begin
  if not (csDestroying in Owner.ComponentState) then
    FSyncMethod(FSyncParams);
end;

procedure TUACustomThread.SynchronizeEx(Method: TNotifyEvent; Params: Pointer);
begin
  if not (csDestroying in Owner.ComponentState) and
     Assigned(Method) then
  begin
    FSyncMethod := Method;
    FSyncParams := Params;
    FThread.Synchronize(InternalSynchronization);
  end;
end;

procedure TUACustomThread.Terminate(Imediately: Boolean);
begin
  if not Assigned(FThread) then Exit;

  if Imediately then
    FThread := FThread.RecreateThread
  else
    FThread.Terminate;
end;

function TUACustomThread.WaitFor:Cardinal;
begin
  Terminate(True);
  Result := FThread.WaitFor;
end;


function  TUACustomThread.GetHandle: THandle;
begin
  Result := FThread.FHandle;
end;

function  TUACustomThread.GetReturnValue: Integer;
begin
  Result := FThread.ReturnValue;
end;

procedure TUACustomThread.SetReturnValue(Value: Integer);
begin
  FThread.ReturnValue := Value;
end;


function TUACustomThread.GetPriority: TThreadPriority;
begin
  Result := FThread.Priority;
end;

procedure TUACustomThread.SetPriority(Value: TThreadPriority);
begin
  FThread.Priority := Value;
end;

function TUACustomThread.GetSuspended: Boolean;
begin
  if csDesigning in ComponentState then
    Result := FDesignSuspended
  else
    Result := FThread.Suspended;
end;

procedure TUACustomThread.SetSuspended(Value: Boolean);
begin
  if csDesigning in ComponentState then
    FDesignSuspended := Value
  else
   begin
    FDesignSuspended := Value;
    FThread.Suspended := Value;
   end; 
end;

function TUACustomThread.GetRunning: Boolean;
begin
  Result := FThread.FRunning;
end;

function TUACustomThread.GetTerminated: Boolean;
begin
  Result := FThread.FTerminated;
end;

function  TUACustomThread.GetThreadID: THandle;
begin
  Result := FThread.ThreadID;
end;


function  TUACustomThread.GetOnException: TNotifyEvent;
begin
  Result := FThread.FOnException;
end;

procedure TUACustomThread.SetOnException(Value: TNotifyEvent);
begin
  FThread.FOnException := Value;
end;

function  TUACustomThread.GetOnExecute: TNotifyEvent;
begin
  Result := FThread.FOnExecute;
end;

procedure TUACustomThread.SetOnExecute(Value: TNotifyEvent);
begin
  FThread.FOnExecute := Value;
end;

function  TUACustomThread.GetOnTerminate: TNotifyEvent;
begin
  Result := FThread.FOnTerminate;
end;

procedure TUACustomThread.SetOnTerminate(Value: TNotifyEvent);
begin
  FThread.FOnTerminate := Value;
end;

initialization
  InitializeCriticalSection(ThreadLock);

finalization
  DeleteCriticalSection(ThreadLock);

end.