(*---------------------------------------------------------------------------
  :Program.    EzRexx.mod, EzRexxAVL.mod
  :Author.     Thomas Igracki
  :Address.    Obstallee 45, 13593 Berlin, Germany
  :E-Mail.     InterNet -> lokai@cs.tu-berlin.de
  :E-Mail.     Z-Netz   -> T.Igracki@BAMP.ZER
  :E-Mail.     Fido     -> Thomas_Igracki%2:2403_10.40
  :Version.    1.5
  :Date.       26-Sep-1993
  :Copyright.  Thomas Igracki (If you like to use it, contact me!)
  :Language.   Oberon
  :Translator. Amiga Oberon 3.00d
  :Contents.   modifiziertes EasyRexx-Modul (von Fridtjof)
  :Usage.      IMPORT EzRexx:
  :Remark.     OS2.0 Only!
 --------------------------------------------------------------------------
 History:
   OpenRexx() gibt jetzt das Signal zurück anstatt das SignalSet!
   EasyRexx läuft jetzt nur noch ab OS2.0, da die Exec-Funcs für CreatePort()
   benutzt werden, anstatt die des ExecSupportModuls

   20-Oct-92: Thomas Igracki
   - UserProc geändert, da ich keine Verwendung für den Parameter 'comm' finden kann
   - DefaulfProcedure eingeführt, bei OpenARexx mitangeben!

   22-Oct-92: Thomas Igracki 
   - SendRexx() Proc. eingebaut.
   - asynchrone Kommandos 

   24-Aug-92: Thomas Igracki
   - Execs Listen anstatt AVL -> kürzerer Code!

   v1.3 (02-Sep-93): Thomas Igracki
   - SendRexx() macht nun bei CED einen ANDEREN Unterschied (wegen CED v3.5)
     Undzwar wird (nur bei 'rexx_ced') gepfrüft, ob RexxArg.length (die
     Länge des ResultStrings) ungleich 0 ist bevor DeleteArgstring() aufgerufen
     wird, da sonst ein 'Memory freed twice' Guru kommt;-(
     Das passiert nur beim CED! Wer weiß warum?

   v1.4 (09.09.93): Thomas Igracki
   - Die Parameter der Kommandos werden nun mit Dos.ReadArgs() geparsed!
   - EasyAddCommand() hat deshalb 2 Parameter mehr,
     'temp' zum übergeben des template strings
     'structSize' die Größe des STRUCTS der für den Befehl die args enthält.
   - 'UserProc' hat sich demzufolge auch geändert.
   - Ein paar neue Type gibts auch.

   v1.41 (15.09.93): Thomas Igracki
   - SendRexx() macht nun keinen Unterschied mehr beim CygnusEd.
     Irgendwie klappt das jetzt doch;-)
   - Tja, vor dem Parsen der Argumente wurde der Speicherbereich nicht gelöscht,
     so daß die vorigen Werte, falls sie nicht geändert wurden beibehalten wurden!
   - bei EasyAddCommand() muß man nicht mehr die Größe des STRUCTs übergeben, das
     wird selbstständig aus dem TempStr berechnet (Anz der Kommas+1)!

   v1.5 (26.09.93): Thomas Igracki
   - Man kann nun per CompilerOption (SET AVL), wieder AVL-Listen benutzen!
     Man muß dann 'EzRexxAVL' anstatt 'EzRexx' importieren!
---------------------------------------------------------------------------*)
(* $IF AVL *) MODULE EzRexxAVL; (* $ELSE *) MODULE EzRexx; (* $END *)

IMPORT
  (* $IF AVL *)
     (* $IF GarbageCollector *) avl: AVL, (* $ELSE *) avl: UntracedAVL,(* $END *)
  (* $END *)
  y: SYSTEM, d: Dos, e: Exec, ol: OberonLib, 
  rsl: RexxSysLib, rx: Rexx, st: Strings;

CONST
  errorImGone = 100;
  errorNoCmd  = 30;

TYPE
  (* $IF AVL *)
  RexxCommandPtr * = (* $IFNOT GarbageCollector *) UNTRACED (* $END *) POINTER TO RexxCommand;
  (* $ELSE *)
  RexxCommandPtr * = UNTRACED POINTER TO RexxCommand;
  (* $END *)

  EzRexxArgsPtr  * = UNTRACED POINTER TO EzRexxArgs;

  DefaultProc * = PROCEDURE (name, args: ARRAY OF CHAR; VAR result: ARRAY OF CHAR);

  UserProc * = PROCEDURE (args: EzRexxArgsPtr; VAR result: ARRAY OF CHAR);

  (* $IF AVL *)
  RexxCommand * = RECORD (avl.SNode)
  (* $ELSE *)
  RexxCommand * = STRUCT (n: e.Node)
  (* $END *)
                    temp * : e.STRPTR;
                    args * : EzRexxArgsPtr;
                    size * : INTEGER; (* Size of args *)
                    proc * : UserProc;
                    async* : BOOLEAN; (* asynchrone Kommandos? *)
                  END;

  EzRexxArgs * = STRUCT END;

  ArgLong        * = UNTRACED POINTER TO LONGINT; (* /N *)
  ArgLongArray   * = UNTRACED POINTER TO ARRAY d.maxMultiArgs OF ArgLong; (* /M/N *)
  ArgBool        * = LONGINT; (* /S, /T *)
  ArgString      * = e.STRPTR; (* /K, /F or nothing *)
  ArgStringArray * = UNTRACED POINTER TO ARRAY d.maxMultiArgs OF ArgString; (* /M/K, /M *)

VAR
  rexxPort : e.MsgPortPtr;           (* this is *our* rexx port           *)
  (* $IF AVL *)
  commands : avl.SRoot;
  (* $ELSE *)
  commands : e.List;                 (* our command list (actually a tree *)
  (* $END *)

  outStandingRMsg : rx.RexxMsgPtr;   (* the outstanding Rexx message *)

  DefProc : DefaultProc;	     (* DefaultProcedure sie wird aufgerufen,*)
  				     (* wenn das Komanndo nicht bekannt war! *)

(*---------------------------------------------------------------------------*)

(* '\n' wird automatisch angehangen! *)
PROCEDURE Parse* (temp, argStr: ARRAY OF CHAR; VAR args: ARRAY OF y.BYTE): d.RDArgsPtr; (* $CopyArrays- *)
VAR RD: d.RDArgsPtr;
BEGIN
     RD := d.AllocDosObjectTags (d.rdArgs, 0); IF RD = NIL THEN RETURN NIL END;

     RD.source.length := st.Length(argStr)+1; (* da noch '\n' angehangen wird! *)
     ol.Allocate (RD.source.buffer,RD.source.length+1); (* +1, wegen 0X! *)
     COPY(argStr,RD.source.buffer^);
     st.Append (RD.source.buffer^,'\n'); (* This is _*VERY*_ important!! *)

     IF d.OldReadArgs (temp,args, RD) = NIL THEN
	DISPOSE (RD.source.buffer); d.FreeDosObject (d.rdArgs, RD); RETURN NIL
     END;
     RETURN RD
END Parse;

PROCEDURE FreeParse* (VAR rd: d.RDArgsPtr);
BEGIN
     IF rd # NIL THEN
        d.FreeArgs (rd); DISPOSE (rd.source.buffer); d.FreeDosObject (d.rdArgs, rd); rd := NIL
     END;
END FreeParse;

(*---------------------------------------------------------------------------*)

PROCEDURE OpenRexx * (name: ARRAY OF CHAR; defProc: DefaultProc): SHORTINT; (* $CopyArrays- *)
(*
 * Öffnet AREXX-Port mit Namen 'name'. Ergebnis ist das Signal des Ports.
 * Konnte der Port nicht geöffnet werden, weil ein Port mit gleichen Namen
 * bereits existiert oder weil zu wenig Speicher vorhanden war, wird
 * -1 zurückgegeben.
 * defProc: Kann auch auf NIL gesetzt werden -> Keine DefaultProzedur!
 *)

BEGIN

  IF rexxPort = NIL THEN

    e.Forbid();
      IF e.FindPort(name) = NIL THEN    (* existiert gleichnamiger Port? *)
        rexxPort := e.CreateMsgPort();  (* Port erzeugen *)
        IF rexxPort # NIL THEN
           ol.Allocate (rexxPort.node.name,st.Length(name)+1); COPY(name,rexxPort.node.name^);
	   rexxPort.node.pri := 0;
           e.AddPort(rexxPort);
        END;
      END;
    e.Permit() ;

  END;

  IF rexxPort # NIL THEN DefProc := defProc; RETURN rexxPort.sigBit (* Signal zurück *)
                    ELSE DefProc := NIL;     RETURN -1 (* Fehler *)
  END;

END OpenRexx;


(*---------------------------------------------------------------------------*)


PROCEDURE AddCommand * (comm: RexxCommandPtr);
(*
 * Fügt ein REXX-Command an die Commandoliste an. comm muß auf eine mit
 * NEW() allozierten RECORD zeigen. In dem RECORD müssen die Felder
 * comm.name für den Commandoname und comm.proc für die aufzurufende
 * Prozedur ausgefüllt werden. comm.proc bekommt die eigene Struktur
 * comm als ersten Parameter übergeben, so daß man durch Erweiterung
 * von comm noch weitere Werte an die Prozedur übergeben kann.
 *
 * Commandos mit gleichen Namen dürfen nur 1 mal mit AddCommand()
 * aktiviert werden, ansonsten bricht das Programm mit rc=20 ab.
 *
 *)

BEGIN
  (* $IF AVL *)
  IF ~avl.Add(commands,comm) THEN HALT(20) END;
  (* $ELSE *)
  e.AddTail(commands,comm);
  (* $END *)

END AddCommand;


(*---------------------------------------------------------------------------*)

PROCEDURE EasyAddCommand* (name, temp: ARRAY OF CHAR; proc: UserProc; async: BOOLEAN): BOOLEAN; (* $CopyArrays- *)
(*
 * Fügt ähnlich AddCommand() ein REXX-Commando an Commandoliste an.
 * Hier wird jedoch lediglich ein standard-RexxCommand erzeugt und
 * das Record kann vom Benutzer nicht erweitert werden.
 *
 * Ergebnis ist FALSE, wenn zu wenig Speicher vorhanden war.
 *
 *)

VAR
  comm: RexxCommandPtr;

  PROCEDURE CountCommas (tmp: ARRAY OF CHAR): INTEGER; (* $CopyArrays- *)
  VAR p,i: INTEGER;
  BEGIN
       (* $IFNOT ClearVars *) p := 0; i := 0; (* $END *)
       WHILE tmp[i] # 0X DO  IF tmp[i] = ',' THEN INC(p) END; INC(i);  END;
       RETURN p
  END CountCommas;

BEGIN

  NEW(comm); IF comm=NIL THEN RETURN FALSE END;

  ol.Allocate (comm.temp,st.Length(temp)+1); COPY(temp,comm.temp^);
  IF temp # '' THEN
     comm.size := (CountCommas(temp)+1)*4;
     IF comm.size > 0 THEN ol.Allocate (comm.args, comm.size) END;
  END;
  comm.proc := proc; comm.async := async;
  (* $IF AVL *)
  COPY(name,comm.name);
  (* $ELSE *)
  ol.Allocate (comm.n.name,st.Length(name)+1); COPY(name,comm.n.name^);
  (* $END *)
  AddCommand(comm);

  RETURN TRUE;

END EasyAddCommand;


(*---------------------------------------------------------------------------*)

PROCEDURE ClearMem (mem: e.APTR; size: INTEGER);
TYPE LongArray = UNTRACED POINTER TO ARRAY MAX(INTEGER) OF LONGINT;
VAR i: INTEGER;
    memArr: LongArray;
BEGIN
     memArr := y.VAL(LongArray,mem);
     FOR i := 0 TO (size DIV 4)-1 DO memArr[i] := 0; END; (* FOR *)
END ClearMem;

PROCEDURE HandleRexx*;
(*
 * Dies Prozedur bearbeitet ankommende Rexx-Commandos. Sie sollte immer dann
 * aufgerufen werden, wenn man den Verdacht hat, daß REXX-Messages angekommen
 * sein könnten. Dies ist z.B. nach dem Aufruf von Exec.Wait(SignalSet+XYZ)
 * der Fall, wenn SignalSet der von OpenRexxPort() erhaltene LONGSET ist.
 *
 * HandleRexxMsg ruft die mit AddCommand() aktivierten Prozeduren auf.
 *
 *)

VAR
  (* $IF AVL *)
  name: avl.String;
  comm: avl.NodePtr;
  (* $ELSE *)
  name: ARRAY 80 OF CHAR;
  comm: e.NodePtr;
  (* $END *)

  RexxMsg: rx.RexxMsgPtr;
  args,result: e.STRING;
  i : INTEGER;
  RD : d.RDArgsPtr;
BEGIN

  IF rexxPort = NIL THEN RETURN END;         (* kein Port -> keine Msg *)

  LOOP

    RexxMsg := e.GetMsg(rexxPort);                (* nächste Msg holen *)
    IF RexxMsg=NIL THEN EXIT END;          (* keine mehr, dann tschüß! *)

    args := RexxMsg.args[0]^;                  (* Argumentstring holen *)

    i := 0;            (* Führende Spaces und Sonderzeichen übergehen: *)
    WHILE (args[i] # 0X) & (args[i] <= " ") DO INC(i) END;
    st.Delete(args,0,i);

    i := 0;                               (* Commandoname extrahieren: *)
    WHILE (args[i] # 0X) & (args[i] >  " ") DO INC(i) END;

    COPY(args,name);                         (* Commandoname nach name *)
    name[i] := 0X;
    st.Upper (name);               (* => Kein Groß/Klein unterscheiden *)

            (* Spaces und Sonderzeichen bis zum 1. Argument übergehen: *)
    WHILE (args[i] # 0X) & (args[i] <= " ") DO INC(i) END;
    st.Delete(args,0,i);

    RexxMsg.result1 := 0;                         (* Result vorbelegen *)
    RexxMsg.result2 := 0;

            (* Msg als unbearbeitet markieren, falls Command abbricht: *)
    outStandingRMsg := RexxMsg;

    (* $IF AVL *)
    comm := avl.SFind (commands,name);             (* Commando suchen: *)
    (* $ELSE *)
    comm := e.FindName (commands,name);            (* Commando suchen: *)
    (* $END *)

    result := "";                         (* Ergebnisstring vorbelegen *)
    IF comm = NIL THEN (* nicht gefunden: evtl. Fehler melden *)
      IF DefProc = NIL THEN (* keine DefaultProcedure *)
         RexxMsg.result1 := errorNoCmd;
         RexxMsg.result2 := y.ADR('Unknown command!');
      ELSE
         DefProc (name,args,result);
      END;
    ELSE
      WITH comm: RexxCommand DO
        IF comm.async THEN
	   outStandingRMsg := NIL; e.ReplyMsg(RexxMsg);
        END;
        IF comm.args # NIL THEN ClearMem (comm.args,comm.size); RD := Parse (comm.temp^, args, comm.args^); END;
        comm.proc (comm.args,result);            (* Commando ausführen *)
        IF comm.args # NIL THEN FreeParse (RD); END;
      END;
    END;   (* IF comm=NIL THEN ... ELSE *)

    (* Wenn Ergebnis vorhanden und von Rexx erwartet, Erbebnis abschicken: *)

    IF (result#"") & ODD(RexxMsg.action DIV rx.rxResult)  THEN
        RexxMsg.result2 := rsl.CreateArgstring(result,st.Length(result));
    END;

    IF (comm = NIL) OR ~comm(RexxCommand).async THEN
       outStandingRMsg := NIL;                   (* Msg ist bearbeitet *)
       e.ReplyMsg(RexxMsg);                         (* und beantworten *)
    END;

  END;   (* LOOP, nach nächste Msg schauen. *)

END HandleRexx;  (* das war's *)


(*---------------------------------------------------------------------------*)


PROCEDURE CloseRexx*; (* Schließt mit OpenRexx() geöffneten AREXX-Port. *)
BEGIN
  IF rexxPort = NIL THEN RETURN END;                       (* kein Port *)

  IF outStandingRMsg # NIL THEN                  (* unbeantwortete Msg? *)
     outStandingRMsg.result1 := errorImGone;          (* Fehler liefern *)
     e.ReplyMsg (outStandingRMsg);                  (* und beantworten. *)
     outStandingRMsg := NIL;
  END;
  e.Forbid;
    LOOP
      outStandingRMsg := e.GetMsg (rexxPort);
      IF outStandingRMsg = NIL THEN EXIT END;
      outStandingRMsg.result1 := errorImGone;         (* Fehler liefern *)
      e.ReplyMsg (outStandingRMsg);                 (* und beantworten. *)
    END;
    DISPOSE(rexxPort.node.name);                      (* Name freigeben *)
    e.RemPort (rexxPort);                             (* Port schließen *)
    e.DeleteMsgPort (rexxPort);
  e.Permit;
  rexxPort := NIL;
END CloseRexx;


(* $CopyArrays- *)
PROCEDURE SendRexx* (rxPortName, com: ARRAY OF CHAR; VAR res : ARRAY OF CHAR): BOOLEAN;
VAR
   Reply, rxPort: e.MsgPortPtr;
   Msg: rx.RexxMsgPtr; strPtr: e.STRPTR;
BEGIN
     (* ARexx-Msg init. *)
     Reply := e.CreateMsgPort(); IF Reply = NIL THEN RETURN FALSE END;
     Msg := rsl.CreateRexxMsg(Reply, NIL, NIL);

     (* Build up the CommandString *)
     Msg.args[0] := rsl.CreateArgstring(com,st.Length(com));
     IF Msg.args[0] = NIL THEN
        rsl.DeleteRexxMsg(Msg); e.DeleteMsgPort (Reply); RETURN FALSE
     END;

     (* result is always wanted *)
     Msg.action := rx.rxComm+rx.rxResult;

     e.Forbid;
       rxPort := e.FindPort (rxPortName);
       IF rxPort = NIL THEN
          rsl.DeleteArgstring (Msg.args[0]); rsl.DeleteRexxMsg(Msg); e.DeleteMsgPort(Reply);
          e.Permit; RETURN FALSE
       ELSE
          e.PutMsg (rxPort,Msg);
       END;
     e.Permit;

     IF rxPort # NIL THEN
        e.WaitPort (Reply); Msg := e.GetMsg (Reply);
        WHILE Msg # NIL DO
            IF Msg.result1 = rx.ok THEN
               IF Msg.result2 # NIL THEN
                  strPtr := Msg.result2; COPY(strPtr^,res);
                  rsl.DeleteArgstring(Msg.result2);
               END;
            ELSE
               res := 'Error'
            END;
            rsl.DeleteArgstring(Msg.args[0]); rsl.DeleteRexxMsg(Msg);
            Msg := e.GetMsg(Reply);
        END; (* WHILE *)
     END; (* IF *)
     e.DeleteMsgPort (Reply);
     RETURN TRUE
END SendRexx;

BEGIN                                  (* Initialisierung: *)
     (* $IF AVL *)
     avl.SInit (commands);
     (* $ELSE *)
     commands.head := y.ADR(commands.tail); commands.tail := NIL; commands.tailPred := y.ADR(commands.head);
     (* $END *)
     outStandingRMsg := NIL; rexxPort := NIL;

CLOSE
   CloseRexx

(* $IF AVL *) END EzRexxAVL. (* $ELSE *) END EzRexx. (* $END *)