HeidiSQL/source/threading.pas

unit threading;

interface

uses
  SysUtils;

type
  // This declaration is needed for the kind of circular typw
  // declaration we make, with Delphi's one-pass compiler.
  TNotifyStructure = class;

  // "of object" means that we expect an instance method,
  // not a procedure which isn't contained in a class.
  TCompletionHandler = procedure(result: TNotifyStructure) of object;

  TNotifyStructure = class
    private
      req: Cardinal;
      res: TObject;
      ex: Exception;
      handler: TCompletionHandler;
      ctl: TObject;
      int: boolean;
    public
      property GetRequestId: Cardinal read req;
      property GetResult: TObject read res;
      property GetException: Exception read ex;
      property GetHandler: TCompletionHandler read handler;
      property GetWaitControl: TObject read ctl;
      property GetWasInterrupted: boolean read int;
      constructor Create(const RequestId: Cardinal; const CompletionHandler: TCompletionHandler; const WaitControl: TObject);
  end;

procedure InitializeThreading(myWindow: THandle);
function SetCompletionHandler(handler: TCompletionHandler; timeout: integer; waitControl: TObject = nil): Cardinal;
procedure NotifyComplete(RequestId: Cardinal; Results: TObject);
procedure NotifyInterrupted(RequestId: Cardinal; AnException: Exception);
procedure NotifyFailed(RequestId: Cardinal; AnException: Exception);
function ExtractResults(RequestId: Cardinal; PeekOnly: Boolean = false): TNotifyStructure;
function ExtractResultObject(RequestId: Cardinal): TObject;

const
  INFINITE_TIMEOUT = $7fffffff;
  REQUEST_ID_INVALID = 0;

implementation

uses
  Windows,
  Communication,
  Helpers,
  Forms,
  Classes;

var
  working: TThreadList;
  msgHandler: THandle;

constructor TNotifyStructure.Create(const RequestId: Cardinal; const CompletionHandler: TCompletionHandler; const WaitControl: TObject);
begin
  self.req := RequestId;
  self.handler := CompletionHandler;
  self.ctl := WaitControl;
  self.res := nil;
  self.ex := nil;
  self.int := false;
end;

function IndexOf(list: TList; RequestId: Cardinal): integer;
var
  i: integer;
begin
  result := -1;
  for i := 0 to list.Count - 1 do begin
    if TNotifyStructure(list[i]).GetRequestId = RequestId then
    begin
      result := i;
      exit;
    end;
  end;
end;

function SetCompletionHandler(handler: TCompletionHandler; timeout: integer; waitControl: TObject = nil): Cardinal;
var
  lockedList: TList;
  ns: TNotifyStructure;
  RequestId: Cardinal;
begin
  debug('thr: Setting completion handler.');
  lockedList := working.LockList;
  try
    // Make a unique request id (blocking until a slot is available if full - hopefully an unlikely event).
    repeat
      RequestId := Random($7fffffff);
    until (RequestId <> REQUEST_ID_INVALID) and (IndexOf(lockedList, RequestId) = -1);
    debug(Format('thr: Assigned request id %d.', [RequestId]));
    result := RequestId;
    // Create + add notify structure.
    ns := TNotifyStructure.Create(RequestId, handler, waitControl);
    lockedList.Add(ns);
    // Optionally start timer.
    if timeout <> INFINITE_TIMEOUT then begin
      // todo: create a timer that activates NotifyInterupted on timeout.
    end;
  finally
    working.UnlockList;
  end;
end;

procedure InternalNotify(RequestId: Cardinal; Results: TObject; AnException: Exception; Interrupted: boolean = false);
var
  lockedList: TList;
  idx: integer;
  item: TNotifyStructure;
begin
  debug(Format('thr: Notifying completion of %d.', [RequestId]));
  lockedList := working.LockList;
  try
    idx := IndexOf(lockedList, RequestId);
    // Abort if we can't find notify structure.
    if idx = -1 then begin
      if not Interrupted then begin
        debug(Format('thr: Received completion notice for %d, but handler does not exist.  Perhaps already completed.', [RequestId]));
      end;
      exit;
    end;
    item := TNotifyStructure(lockedList[idx]);
    // Abort if result or exception has already been set.
    if (item.res <> nil) or (item.ex <> nil) then begin
      if item.int then begin
        // Destroy notify structure if receiving results from previously interrupted operation.
        lockedList.Delete(idx);
      end else begin
        if not Interrupted then begin
          debug(Format('thr: Received completion notice for %d, but handler already has result or exception.  Perhaps already completed, but handler hasn''t been activated yet.', [RequestId]));
        end;
      end;
      exit;
    end;
    // Set result.
    item.res := Results;
    item.ex := AnException;
    item.int := Interrupted;
    // Stop timer.
    // todo: stop timeout timer.
  finally
    working.UnlockList;
  end;
  // Send a message to the active message loop indicating
  // that processing has completed.
  PostMessage(msgHandler, WM_COMPLETED, msgHandler, item.GetRequestId);
end;

procedure NotifyComplete(RequestId: Cardinal; Results: TObject);
begin
  InternalNotify(RequestId, Results, nil);
end;

procedure NotifyInterrupted(RequestId: Cardinal; AnException: Exception);
begin
  InternalNotify(RequestId, nil, AnException, true);
end;

procedure NotifyFailed(RequestId: Cardinal; AnException: Exception);
begin
  InternalNotify(RequestId, nil, AnException);
end;

function ExtractResults(RequestId: Cardinal; PeekOnly: Boolean = false): TNotifyStructure;
var
  lockedList: TList;
  idx: integer;
  txt: string;
begin
  result := nil;
  lockedList := working.LockList;
  try
    idx := IndexOf(lockedList, RequestId);
    // Raise an exception if we can't find notify structure.
    if idx = -1 then begin
      txt := Format('thr: Request %d does not exist, cannot extract results.', [RequestId]);
      debug(txt);
      raise Exception.Create(txt);
    end;
    // Remove notify structure from list and return it to caller.
    result := TNotifyStructure(lockedList[idx]);
    if (not PeekOnly) and (not result.int) then lockedList.Delete(idx);
  finally
    working.UnlockList;
  end;
end;

function ExtractResultObject(RequestId: Cardinal): TObject;
var
  res: TNotifyStructure;
  ex: Exception;
  o: TObject;
begin
  res := ExtractResults(RequestId);
  o := res.GetResult;
  ex := res.GetException;
  res.Free;
  if o <> nil then begin
    result := o;
    exit
  end else if ex <> nil then begin
    raise ex;
  end else begin
    raise Exception.Create('Internal error in caller: no results available yet.');
  end;
end;


procedure InitializeThreading(myWindow: THandle);
begin
  msgHandler := myWindow;
end;


initialization
  working := TThreadList.Create;

finalization
  FreeAndNil(working);

end.