(* ------------------------------------------------------------------------
  :Program.       ObSup
  :Contents.      oberonsupport.library: easy handling of Oberon-Errors
  :Author.        Kai Bolay [kai]
  :Address.       Snail-Mail:              E-Mail:
  :Address.       Hoffmannstraße 168       UUCP: kai@amokle.tynet.sub.org
  :Address.       D-7250 Leonberg 1        FIDO: 2:247/706.3
  :History.       v1.0 [kai] 12-Mar-92
  :History.       v1.1 [kai] 26-Mar-92 (GETERRORCOUNT-Bug fixed)
  :Copyright.     © 1992 by Kai Bolay
  :Copyright.     permission is herby given to Fridtjof Siebert to include
  :Copyright.     this source into his comercial distribution
  :Language.      Oberon
  :Translator.    AMIGA OBERON v2.25d
  :Imports.       RVI [Martin Horneffer], StringOps [bne]
  :Remark.        Include this into oberon.library
  :Bugs.          Functions do not use RegArgs, not very stable :-(
------------------------------------------------------------------------ *)

(* WITH-File for LibLink:

MAIN ObSup

PROC ObSup.ARexxQuery
PROC ObSup.FreeErrorFile
PROC ObSup.ReadErrorFile
PROC ObSup.GetErrorText

VERSION 1
REVISION 1
TO LIBS:oberonsupport.library
XREF T:ObSup.xref
SMALL

*)

MODULE ObSup;

IMPORT
  d: Dos, e: Exec, so: StringOps, rx: Rexx, rsl: RexxSysLib, RVI,
  y: SYSTEM (* $IF Debug *) ,Debug, rq: Requests, ol: OberonLib,
  es: ExecSupport (* $END *);


TYPE
  Error- = STRUCT
    num-: INTEGER;
    line-, column-: INTEGER;
  END;
  Errors- = UNTRACED POINTER TO ARRAY OF Error;

VAR
  ErrorTexts: UNTRACED POINTER TO ARRAY OF CHAR;
  ErrorPos: ARRAY 250 OF LONGINT;
  NumErrors, pos, len: LONGINT;
  Text: ARRAY 100 OF CHAR;

(* $Debug- *)

PROCEDURE GetFileLen (file: d.FileHandlePtr): LONGINT;
VAR
  length, oldpos: LONGINT;
BEGIN
  oldpos := d.Seek (file, 0, d.end);
  IF oldpos = -1 THEN RETURN -1 END;
  length := d.Seek (file, 0, d.current);
  IF d.Seek (file, oldpos, d.beginning) = -1 THEN RETURN -1 END;
  RETURN length;
END GetFileLen;

PROCEDURE FreeErrorFile* (Errs: Errors);
BEGIN
  DISPOSE (Errs);
END FreeErrorFile;

PROCEDURE ReadErrorFile* (name: ARRAY OF CHAR; VAR Errs: Errors): BOOLEAN;
VAR
  file: d.FileHandlePtr;
  length: LONGINT;
BEGIN
  Errs := NIL;
  file := d.Open (name, d.oldFile);
  IF file # NIL THEN
    length := GetFileLen (file);
    IF (length # -1) AND (length MOD y.SIZE (Error) = 0) THEN
      NEW (Errs, length DIV 6);
      IF Errs # NIL THEN
        IF d.Read (file, Errs^, length) = length THEN
          d.OldClose (file);
          RETURN TRUE;
        END;
        DISPOSE (Errs);
      END;
    END;
    d.OldClose (file);
  END;
  RETURN FALSE;
END ReadErrorFile;

PROCEDURE GetErrorText* (num: INTEGER; VAR text: ARRAY OF CHAR): BOOLEAN;
VAR
  pos, i: LONGINT;
BEGIN
  IF (num < 0) OR (num >= NumErrors) THEN RETURN FALSE END;
  pos := ErrorPos[num]; i := 0;
  LOOP
    text[i] := ErrorTexts[pos];
    IF text[i] = 0AX THEN EXIT END;
    INC (i); INC (pos);
    IF LEN (text) < i THEN RETURN FALSE END;
  END;
  text[i] := 0X;
  RETURN TRUE;
END GetErrorText;
(* $Debug= *)


(* $IF Debug *)
(* $Debug- *)
PROCEDURE OpenDebugger;
BEGIN
  Debug.Me := y.VAL(d.ProcessPtr,ol.Me);

  INCL(ol.MemReqs,e.public);
  NEW(Debug.msg);
  EXCL(ol.MemReqs,e.public);
  rq.Assert(Debug.msg#NIL,Debug.oom);
  Debug.replyPort := es.CreatePort("",0); rq.Assert(Debug.replyPort#NIL,Debug.oom);
  Debug.msg.msg.replyPort := Debug.replyPort;
  Debug.msg.msg.length    := y.SIZE(Debug.DebugMsg);
  Debug.msg.odebugAlive := TRUE;

  LOOP
    e.Forbid;
      Debug.dbPort  := e.FindPort(Debug.ODebugPort);
      IF Debug.dbPort#NIL THEN
        WITH Debug.dbPort : Debug.DebugPort DO
          IF Debug.dbPort.inuse THEN
            Debug.dbPort := NIL;
            e.Permit;
            Debug.msg.odebugAlive := FALSE;
            IF rq.Request(Debug.ODebugAktiv1,Debug.ODebugAktiv2,
                          Debug.Run,Debug.Cancel) THEN EXIT ELSE HALT(20);
            END;
          END;
          Debug.dbPort.inuse := TRUE;
        END;
        e.Permit;
        EXIT
      END;
    e.Permit;
    IF NOT rq.Request(Debug.StartODebug1,Debug.StartODebug2,Debug.Retry,Debug.Run) THEN
      Debug.msg.odebugAlive := FALSE;
      EXIT
    END;
  END;

  IF Debug.msg.odebugAlive THEN
    Debug.msg.action := Debug.hereweare;
    e.PutMsg(Debug.dbPort,Debug.msg);
    REPEAT
      e.WaitPort(Debug.replyPort);
    UNTIL e.GetMsg(Debug.replyPort)=Debug.msg;
  END;
END OpenDebugger;
(* $Debug= *)
(* $END *)

(* $IFNOT Debug *)
PROCEDURE OpenDebugger;
BEGIN END OpenDebugger;
(* $END *)

(* $IF Debug *)
(* $Debug- *)
PROCEDURE CloseDebugger;
BEGIN
  IF Debug.dbPort#NIL THEN
    IF Debug.msg.odebugAlive THEN
      Debug.msg.action := Debug.cheerio;
      e.PutMsg(Debug.dbPort,Debug.msg);
      REPEAT
        e.WaitPort(Debug.replyPort);
      UNTIL e.GetMsg(Debug.replyPort)=Debug.msg;
    END;
  END;
  IF Debug.replyPort#NIL THEN es.DeletePort(Debug.replyPort) END;
END CloseDebugger;
(* $Debug= *)
(* $END *)

(* $IFNOT Debug *)
PROCEDURE CloseDebugger;
BEGIN END CloseDebugger;
(* $END *)


PROCEDURE RealQuery (RxMsg: rx.RexxMsgPtr; VAR ResultString: e.STRPTR): LONGINT;
VAR
  i: LONGINT;
  BaseVar, CompVar: ARRAY 100 OF CHAR;
  Errs: Errors;
  ok: BOOLEAN;

  PROCEDURE SetRexxNum (VarName: ARRAY OF CHAR; num: LONGINT): BOOLEAN;
  VAR
    NumStr: ARRAY 10 OF CHAR;
  BEGIN
    so.IntToStr (num, NumStr);
    RETURN RVI.SetRexxVar (RxMsg, VarName, NumStr, so.Length (NumStr))=0;
  END  SetRexxNum;

  PROCEDURE FillErrStem (Base: ARRAY OF CHAR; Err: Error): BOOLEAN;
  BEGIN
    so.Concat (Base, ".NUM", CompVar);
    IF NOT SetRexxNum (CompVar, Err.num) THEN RETURN FALSE END;
    so.Concat (Base, ".LINE", CompVar);
    IF NOT SetRexxNum (CompVar, Err.line) THEN RETURN FALSE END;
    so.Concat (Base, ".COLUMN", CompVar);
    IF NOT SetRexxNum (CompVar, Err.column) THEN RETURN FALSE END;
    RETURN TRUE;
  END FillErrStem;

BEGIN
  ok := FALSE;
  ResultString := NIL;
  IF RVI.CheckRexxMsg (RxMsg) AND (RxMsg.args[0] # NIL) THEN
    i := RxMsg.action MOD 256;
    IF (RxMsg.args[0]^ = "READERRORFILE") AND (i = 2) THEN
      IF (RxMsg.args[1] # NIL) AND (RxMsg.args[2] # NIL) THEN
        i := so.Length (RxMsg.args[2]^)-1;
        IF (i > 1) AND (RxMsg.args[2]^[i] = '.') THEN
          IF ReadErrorFile (RxMsg.args[1]^, Errs) THEN
            so.Concat (RxMsg.args[2]^, "COUNT", CompVar);
            IF SetRexxNum (CompVar, LEN (Errs^)) THEN
              i := 0;
              LOOP
                IF i = LEN (Errs^) THEN EXIT END;
                so.IntToStr (i, BaseVar);
                so.Concat (RxMsg.args[2]^, BaseVar, BaseVar);
                IF NOT FillErrStem (BaseVar, Errs[i]) THEN EXIT END;
                INC (i);
              END;
              ok := (i = LEN (Errs^));
            END;
            FreeErrorFile (Errs);
          ELSE
            ok := FALSE;
          END;
          IF ok THEN
            ResultString := rsl.CreateArgstring ("1", 1);
            RETURN 0;
          ELSE
            ResultString := rsl.CreateArgstring ("0", 1);
            RETURN 0;
          END;
        END;
      END;
    ELSIF (RxMsg.args[0]^ = "GETERRCOUNT") AND (i = 1) THEN
      IF (RxMsg.args[1] # NIL) AND ReadErrorFile (RxMsg.args[1]^, Errs) THEN
        so.IntToStr (LEN (Errs^), BaseVar);
        ResultString := rsl.CreateArgstring (BaseVar, so.Length (BaseVar));
        FreeErrorFile (Errs);
        RETURN 0;
      ELSE
        ResultString := rsl.CreateArgstring ("-1", 2);
        RETURN 0;
      END;
    ELSIF (RxMsg.args[0]^ = "GETERROR") AND (i = 3) THEN
      IF (RxMsg.args[1] # NIL) AND (RxMsg.args[2] # NIL) AND
         (RxMsg.args[3] # NIL) THEN
        COPY (RxMsg.args[3]^, BaseVar);
        i := so.Length (BaseVar)-1;
        IF (i > 1) AND (BaseVar[i] = '.') THEN
          BaseVar[i] := 0X;
          IF ReadErrorFile (RxMsg.args[1]^, Errs) THEN
            i := so.StrToInt (RxMsg.args[2]^);
            IF (i >= 0) AND (i < LEN (Errs^)) THEN
              ok := FillErrStem (BaseVar, Errs[i]);
            END;
            FreeErrorFile (Errs);
          ELSE
            ok := FALSE;
          END;
          IF ok THEN
            ResultString := rsl.CreateArgstring ("1", 1);
            RETURN 0;
          ELSE
            ResultString := rsl.CreateArgstring ("0", 1);
            RETURN 0;
          END;
        END;
      END;
    ELSIF (RxMsg.args[0]^ = "GETERRORTEXT") AND (i = 1) THEN
      i := so.StrToInt (RxMsg.args[1]^);
      BaseVar := "unknown";
      IF GetErrorText (SHORT (i), BaseVar) THEN END;
      ResultString := rsl.CreateArgstring (BaseVar, so.Length (BaseVar));
      RETURN 0;
    END; (* IF *)
  END;
  RETURN 1;
END RealQuery;

(* $Debug- $SaveRegs+ *)
PROCEDURE ARexxQuery* (RxMsg{8}: rx.RexxMsgPtr): LONGINT;
VAR
  ResultString: e.STRPTR;
  ret: LONGINT;
BEGIN
  OpenDebugger;
  ret := RealQuery (RxMsg, ResultString);
  CloseDebugger;
  y.SETREG (8, ResultString);
  RETURN ret;
END ARexxQuery;
(* $Debug= *)

(* $Debug- *)
PROCEDURE ReadErrorTexts (name: ARRAY OF CHAR): LONGINT;
VAR
  file: d.FileHandlePtr;
  length: LONGINT;
BEGIN
  file := d.Open (name, d.oldFile);
  IF file # NIL THEN
    length := GetFileLen (file);
    IF length > 1 THEN
      NEW (ErrorTexts, length);
      IF ErrorTexts # NIL THEN
        IF d.Read (file, ErrorTexts^, length) = length THEN
          IF ErrorTexts[length-1] = 0AX THEN
            d.OldClose (file);
            RETURN length;
          END;
        END;
        DISPOSE (ErrorTexts);
      END;
    END;
    d.OldClose (file);
  END;
  RETURN -1;
END ReadErrorTexts;

BEGIN
  len := ReadErrorTexts ("OBERON:Fehler-Meldungen");
  IF len = -1 THEN HALT (20) END;
  NumErrors := 0; pos := 0;
  WHILE pos < len DO
    ErrorPos[NumErrors] := pos;
    WHILE ErrorTexts[pos] # 0AX DO
      INC (pos);
    END; (* WHILE *)
    INC (NumErrors); INC (pos);
  END; (* WHILE *)

  IF GetErrorText (15, Text) THEN END;
CLOSE
  IF ErrorTexts # NIL THEN DISPOSE (ErrorTexts) END;
END ObSup.