itignet.pas

autoupdate 1.02 source code

unit itignet;

interface

uses Windows, Messages, Classes, Dialogs, ShellAPI,
     Forms, WinBinFile, Progress, ItigOptions, SysUtils, postfile;

type TDebugMethod = procedure(S : String) of object;

const WM_THREAD_COMPLETE = WM_USER + 2;
// used by TestConnect
const CONNECT_OK = 0;
const CONNECT_CERT_NOT_INSTALLED = 1;

const wtExit = 'EXIT';

// Possible values for ResultCode
const irOK = 0;
const irError = 1;
const irCancel = 2;
const irReady = 3;
const irTryAgain = 4;

type
   TItigNet = class;
   TRPCContext = class;

   TRPCMethod = procedure(Context : TRPCContext) of object;

   TMethodPointer = class
   public
      Method : TMethod;

      procedure SetMethod(p : Pointer);
      procedure GetMethod(p : Pointer);
   end;

   TRPCContext = class
   public
      Network : TItigNet;
      Post : TPostFile;
      Results : TStringList;
      Keys : TStringList;
      Values : TStringList;

      constructor Create(Net : TItigNet);
      destructor Destroy; override;

      procedure AddKeyValue(Key : String; Value : String);
      procedure Execute(FileName : String);
      procedure ReceiveFile(FileName : String; ReceiveFileName : String);
   end;


   TItigNet = class(TThread, IProgress)
   public

      ResultCode : Integer;

      Option : TItigOptions;

      constructor Create(fHandle : hWnd; fDebugMethod : TDebugMethod; fGetProxyMethod : TGetProxyFunction);
      destructor Destroy; override;
      procedure ThreadComplete(var Message: TMessage);
      procedure WaitEvent(Handle : THandle);

      function GetResult : Integer;
      procedure ClearResult;
      function GetErrorMsg: String;

      procedure BeginExecute(Action : String; progress: IProgress);
      procedure Execute; override;
      procedure GotMessage;

      //Autodial code
      function isConnected: Boolean;
      function Dial: Boolean;
      procedure Hangup;

      procedure Debug(S : String);

      procedure OpenLogFile;
      procedure Log(S : String);
      procedure CloseLogFile;
      procedure RegisterRPC(Name : String; Method : TRPCMethod);

   private
      RPCMethods : TStringList;
      DebugMethod : TDebugMethod;
      Handle : hWnd;
      //ThreadAction : Integer;
      ThreadAction : String;

      Prog : IProgress;
      ErrorMessage : String;
      ShuttingDown : Boolean;

      Event1 : THandle;
      Event2 : THandle;
      MainThreadID : DWORD;

   //
   // for thread safe debug
   DebugString : String;
   ptVal : Integer;
   ptMsg : String;

      procedure ThreadDebug;
      procedure DecodeResults(Keys : TStringList; Values : TStringList; Results : TStringList);

      // This is a thread safe implementation of the IProgress interface
        procedure setMessage(msg: String);
        procedure setNoActions(toVal: Integer);
        procedure setPos(Position: Integer);
        procedure actionDone();
        procedure Done;
        procedure setPhases(toPhases: integer);
        procedure phaseDone;
        function GetHandle : hWnd;
        function IsCancelled : Boolean;
      //
       function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
       function _AddRef: Integer; stdcall;
       function _Release: Integer; stdcall;
       //
         procedure ptSetMessage;
         procedure ptSetNoAct;
         procedure ptSetPos;
         procedure ptActionDone;
         procedure ptDone;
         procedure tpSetPhases;
         procedure tpPhaseDone;

      procedure TestRPC(Context : TRPCContext);
   end;



implementation

uses WinInet, FileCtrl;

// call like this mp.SetMethod(@@MyMethod)
procedure TMethodPointer.SetMethod(p : Pointer);
begin
   CopyMemory(@Method, p, sizeof(TMethod));
end;

// call like this mp.GetMethod(@@MyMethod)
procedure TMethodPointer.GetMethod(p : Pointer);
begin
   CopyMemory(p, @Method, sizeof(TMethod));
end;

constructor TRPCContext.Create(Net : TItigNet);
begin
   Network := Net;
   Results := TStringList.Create;

   Post := TPostFile.Create(Net.Option, Net.DebugMethod, Net);
   Keys := TStringList.Create;
   Values := TStringList.Create;
   Post.ScriptName := Net.Option.GetScriptName;

end;

destructor TRPCContext.Destroy;
begin
   Keys.Free;
   Values.Free;
   Results.Free;
   Post.Free;
end;

procedure TRPCContext.AddKeyValue(Key : String; Value : String);
begin
   Keys.Add(Key);
   Values.Add(Value);
end;

procedure TRPCContext.Execute(FileName : String);
begin
   Post.Post(Keys, Values, FileName, Results);
   Network.DecodeResults(Keys, Values, Results);
end;

procedure TRPCContext.ReceiveFile(FileName : String; ReceiveFileName : String);
begin
   Post.ReceiveFile(Keys, Values, FileName, ReceiveFileName, Results);
   Network.DecodeResults(Keys, Values, Results);
end;


procedure TItigNet.Debug(S : String);
begin
   if not ShuttingDown then
   begin
      if Assigned(DebugMethod) then
      begin
         if GetCurrentThreadId = MainThreadID then
         begin
            DebugMethod(S);
         end
         else
         begin
            DebugString := S;
            Synchronize(ThreadDebug);
         end;
      end;
   end;
end;

procedure TItigNet.ThreadDebug;
begin
   DebugMethod(DebugString);
end;

constructor TItigNet.Create(fHandle : hWnd; fDebugMethod : TDebugMethod; fGetProxyMethod : TGetProxyFunction);
begin
   MainThreadID := GetCurrentThreadID; 
   ShuttingDown := False;
   Event1 := CreateEvent(nil, True, False, nil);
   Event2 := CreateEvent(nil, True, False, nil);

   inherited Create(False);

   OpenLogFile;

   Handle := fHandle;
   DebugMethod := fDebugMethod;

   Option := TItigOptions.Create;
   Option.GetProxyMethod := fGetProxyMethod;
   Option.LoadInternet;

   ResultCode := irReady;

   RPCMethods := TStringList.Create;

   RegisterRPC('TEST', TestRPC);

//   Resume;

end;

procedure TItigNet.TestRPC(Context : TRPCContext);
begin
   Debug('Test works!');
end;

destructor TItigNet.Destroy;
var
   i : Integer;
begin
   WaitEvent(Event1);
   CloseHandle(Event2);
   CloseHandle(Event1);

   CloseLogFile;

   for i := 0 to RPCMethods.Count - 1 do
   begin
      RPCMethods.Objects[i].Free;
   end;
   RPCMethods.Free;
   RPCMethods := nil;

   inherited Destroy;
end;

procedure TItigNet.ThreadComplete(var Message: TMessage);
begin
//   Debug('ThreadComplete message');
end;


procedure TItigNet.DecodeResults(Keys : TStringList; Values : TStringList; Results : TStringList);
var
   i : Integer;
   Temp : String;
   p : Integer;
   NewKey : String;
   NewValue : String;
   ExplicitError : Boolean;
begin
   Keys.Clear;
   Values.Clear;
   // check for status...  If there is no status then ResultCode will
   // be irError.  It is and error if a script does not return a status
   ErrorMessage := 'The script did not return a status code';
   ResultCode := irError;
   ExplicitError := False;

   for i := 0 to Results.Count - 1 do
   begin
      if Length(Results[i]) > 0 then
      begin
         Temp := Results[i];
         if Temp[1] = '+' then
         begin
            Delete(Temp, 1, 1);
            p := pos(': ', Temp);
            NewKey := Copy(Temp, 1, p - 1);
            Delete(Temp, 1, p + 1);
            NewValue := Temp;

            Keys.Add(NewKey);
            Values.Add(NewValue);

            if NewKey = 'status' then
            begin
               if NewValue = 'Success' then
               begin
                  ResultCode := irOK;
               end
               else if NewValue = 'Error' then
               begin
                  if not ExplicitError then
                  begin
                     ErrorMessage := 'Script reported an error';
                  end;
                  ResultCode := irError;
               end;
            end
            else if NewKey = 'error' then
            begin
               ErrorMessage := NewValue;
               ExplicitError := True;
            end;

         end;
      end;
   end;

   if ResultCode <> irOK then
   begin
      Debug(Results.Text);
   end;

   if ExplicitError then
   begin
      ResultCode := irError; // sometimes we get an error and success...
   end;

{   for i := 0 to Keys.Count - 1 do
   begin
      Debug('Key -' + Keys[i] + '- Value -' + Values[i] + '-');
   end;}
end;



procedure TItigNet.WaitEvent(Handle : THandle);
var
   R : DWORD;
begin
   if GetCurrentThreadId = MainThreadID then
   begin
     Debug('Wait Handle');
     R := WaitForSingleObject(Handle, 0);
     if R = WAIT_OBJECT_0 then
     begin
        Debug('Clear Handle');
     end
     else
     begin
        while True do
        begin
           Application.ProcessMessages;
           Debug('Handle is not signaled....  waiting up to 1 second...');
           R := WaitForSingleObject(Handle, 100);
           if R = WAIT_OBJECT_0 then
           begin
              Debug('Clear Handle');
              break;
           end
        end;
     end;
   end
   else
   begin
      Debug('Wait Handle');
      WaitForSingleObject(Handle, INFINITE);
   end;
   ResetEvent(Handle);
end;

//This is the main method of the InfoIn class
procedure TItigNet.BeginExecute(Action : String; progress: IProgress);
begin
   if ShuttingDown then
   begin
      raise Exception.Create('ITIGNet component is already shutting down');
   end;
   if Assigned(Progress) then
   begin
      Handle := progress.GetHandle;
   end
   else
   begin
      Handle := 0;
   end;
   ThreadAction := Action;
   try
      Prog := Progress;
   except
      on E : Exception do
      begin
         ShowMessage('How can there be an exception here?' + E.Message);
      end;
   end;

   if Action = wtExit then
   begin
      ShuttingDown := True;
   end;

   Debug('Set E2');
   SetEvent(Event2);
end;

procedure TItigNet.GotMessage;
begin
   WaitEvent(Event1);
end;

// This is the start of the work thread.
procedure TItigNet.Execute;
var
   Quit: Boolean;
   i : Integer;
   Method : TRPCMethod;
   MethodPointer : TMethodPointer;
   Context : TRPCContext;
begin
   Quit := false;

   WaitEvent(Event2);

   while not Quit do
   begin
      ErrorMessage := 'Unknown Error';
      try
         Debug('IAA Executing');

         if ResultCode <> irReady then
         begin
            Debug('Execute called when ResultCode is not Ready');
         end;

         // look up the method name in the list of methods...
         if Assigned(RPCMethods) then
         begin
            for i := 0 to RPCMethods.Count - 1 do
            begin
               if RPCMethods[i] = ThreadAction then
               begin
                  // call the test method...
                  MethodPointer := TMethodPointer(RPCMethods.Objects[i]);
                  MethodPointer.GetMethod(@@Method);

                  // set up the context for the RPC call
                  Context := TRPCContext.Create(self);
                  try
                     Method(Context);
                  finally
                     Context.Free;
                  end;
               end;