PROGRAM answer(input, output);
(* Runs under BYERSX system. v1.0 85/11/25, C.B. Falconer  *)
(* Checked on Prometheus 1200 and USR Password modems with *)
(* DTR control.  Strings are initialized to 20 bytes, and  *)
(* patchable. If the "execute" string is all blanks it is  *)
(* not used, else an incoming call chains to that command  *)
(* in secure mode (forceing disconnect on program exit,    *)
(* unless the program exits by "ret" to ccp, or by chain.) *)
(* Run with "A>answer" or "A>answer [2]" to monitor setup. *)
(*     with "A>answer [4]" or "A>answer [6] for 2400 baud. *)
(* This program compiles and executes under the PascalP    *)
(* system, which is freely available.  Extensions to Std.  *)
(* Pascal are encapsulated in procedures, for portability. *)
(* Extension system procedures may be uncovered by a comp- *)
(* ilation with the {$p-} flag set.  See also {s-} flags.  *)

(* Copyright (c) 1985 by                                   *)
(*   C.B. Falconer, 680 Hartford Tpk, Hamden, Conn. 06517  *)
(* all rights reserved.                 (203) 281-1438     *)
(* This program may be copied, modified, and used freely.  *)
(* It may not be sold without the express written permis-  *)
(* sion of C.B.Falconer.                                   *)

(* 1.2 85/12/19. 2400 baud version selected by parm=4,     *)
(*     allowing ENDCALL to control.  Arm failure now backs *)
(*     down to 1200 baud. Eliminated sysop password, since *)
(*     SETWHEEL covers the function.  Avoids two versions. *)
(* 1.1 85/12/16. Simplified and renamed ANSWER from BYE.   *)
(* 1.0 85/12/09. Original release.                         *)

  CONST
    ver            = 'ANSWER v1.2 using BYERSX v';
    maxstring      = 30;
    xmaxstring     = 31;        (* maxstring + 1 *)
(*$s- non-std Pascal *)
    bs             = (:8:);
    lf             = (:10:);
    cr             = (:13:);
    eos            = (:0:);     (* end of string marker *)
(*$s+*)
    debugc         = false;     (* password input *)
    debugd         = false;     (* simulated calls to answer *)

(*$i'rsxcalls.inc' *)

  TYPE
    systemcall     = 0..swrtprotect;
    baudrate       = (baudquery, b110, b300, b450, b600, b710,
                      b1200, b2400, b4800, b9600, b19200);
    anerror        = (noterror, norsx, comminit, baudinit);

    xstrindex      = 0..maxstring;
    strindex       = 1..maxstring;
    xxstrindex     = 1..xmaxstring;
    string         = PACKED ARRAY[xxstrindex] OF char; (* eos terminated *)

  VAR
    (* initialized Smart Modem Command strings *)
    atz,                       (* init to power up state *)
    atprime,                   (* pre-arm, needed for Prometheus *)
    atinit,                    (* configure modem *)
    atnoansw,                  (* inhibit answering, on exit *)
    execute,                   (* Prog. on call, null for none *)
    password       : string;   (* initialized passwords, user *)
    have2400,                  (* else 1200 baud maximum *)
    debugm         : boolean;  (* monitor strings to/from modem *)

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

  PROCEDURE readlnstring(VAR f : text; VAR s : string);
  (* The input string is terminated by eoln (usually cr).       *)

    VAR
      i     : xxstrindex;

    BEGIN (* readlnstring *)
    i := 1;
    WHILE NOT eoln(f) DO
      IF i < xmaxstring THEN BEGIN
        read(f, s[i]); i := succ(i); END
      ELSE get(f);
    s[i] := eos; readln(f);
    END; (* readlnstring *)

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

  FUNCTION length(VAR s : string) : xstrindex;
  (* better implemented as a macro. *)

    BEGIN (* length *)
    length := pred(scanfor(eos, s, xmaxstring));
    (* rangerror for invalid string, with no eos mark *)
    END; (* length *)

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

  PROCEDURE stringupshift(VAR s : string);

    CONST
      upconvert = 32;  (* ord('a') - ord('A') *)

    VAR
      i         : xstrindex;

    BEGIN (* stringupshift *)
    FOR i := 1 TO length(s) DO
      IF s[i] IN ['a'..'z'] THEN
        s[i] := chr(ord(s[i]) - upconvert);
    END; (* stringupshift *)

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

  PROCEDURE stringdeblank(VAR s : string)
  (* remove trailing blanks, if any *);

    VAR
      i    : integer;

    BEGIN (* stringdeblank *)
    i := length(s);
    WHILE i > 0 DO
      IF s[i] <> ' ' THEN i := 0 (* force exit *)
      ELSE BEGIN
        s[i] := eos; i := pred(i); END;
    END; (* stringdeblank *)

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

  PROCEDURE stringextend(VAR s : string; ch : char; always : boolean)
  (* always false prevents extension if the terminal *)
  (* char is ch, or if the string is null (length=0) *);

    VAR
      l    : integer;

    BEGIN (* stringextend *)
    l := length(s);
    IF l = 0 THEN BEGIN
      IF always THEN BEGIN
        s[1] := ch; s[2] := eos; END;
      END
    ELSE IF l < maxstring THEN
      IF (s[l] <> ch) OR always THEN BEGIN
        s[succ(l)] := ch; s[l + 2] := eos; END;
    END; (* stringextend *)

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

  PROCEDURE stringclean(VAR s : string)
  (* This standardizes the portion beyond the eos marker. *);
  (* Thus straight lexical comparisons can be made.       *)
  (* Because strings are meaningless beyond their length, *)
  (* this does not affect any other string operations.    *)
  (* Comparisons depend on the fact that eos is zero, so  *)
  (* that a string vs string+suffix compares correctly.   *)
  (* This should be called after any string has been mod- *)
  (* ified, and before any comparison is made.  It need   *)
  (* not be called again unless the string is modified.   *)

    VAR
      i    : xxstrindex;

    BEGIN (* stringclean *)
    FOR i := succ(length(s)) TO xmaxstring DO s[i] := eos;
    END; (* stringclean *)

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

  PROCEDURE error(x : anerror; parm : integer);

    BEGIN (* error *)
    IF x <> noterror THEN BEGIN
      CASE x OF
norsx:
        write('BYERSX not running');
comminit:
        write('Comm. system');
baudinit:
        write('Baud bad');
        END; (* case *)
      writeln; terminate; END;
    END; (* error *)

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

  PROCEDURE pause(millisecs : integer);

    VAR
      junk   : integer;

    BEGIN (* pause *)
    junk := syscall(dodelay, millisecs);
    END; (* pause *)

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

  PROCEDURE setvalue(s : systemcall; v : integer);

    VAR
      junk   : integer;

    BEGIN (* setvalue *)
    junk := syscall(s, v);
    END; (* setvalue *)

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

  PROCEDURE putchar(c : char); (* to modem port directly *)

    VAR
      junk    : integer;

    BEGIN (* putchar *)
    WHILE syscall(moutstat, 0) = 0 DO (* nothing, wait *);
    junk := syscall(mout, c);
    END; (* putchar *)
    
  (* 1---------------1 *)

(*$x+,n-,d- save options, no range checks no line numbers *)

  FUNCTION expectchar(VAR c : char; timeout : integer) : boolean;
  (* Get char from modem if it appears in timeout millisecs *)
  (* return false if timeout occurs, else true              *)

    VAR
      junk   : boolean;

    BEGIN (* expectchar *)
    WHILE (timeout > 0) AND (syscall(minstat, 255) = 0) DO BEGIN
      timeout := pred(timeout); pause(1); END;
    IF syscall(minstat, 255) <> 0 THEN BEGIN
      expectchar := true; c := chr(mask(syscall(min, 0), 127));
      IF debugm THEN
        IF c > ' ' THEN write(c)
        ELSE writeln('<', ord(c) : 1, '>'); END
    ELSE IF debugd THEN BEGIN
      write('-->'); prompt; expectchar := true;
      IF eoln THEN expectchar := false
      ELSE read(c);
      IF c = '|' THEN c := cr;
      readln; END
    ELSE expectchar := false;
    END; (* expectchar *)

(*$x- restore options *)

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

  PROCEDURE putmdmstring(VAR s : string);

    VAR
      i     : integer;

    BEGIN (* putmdmstring *)
    i := 1;
    WHILE s[i] <> eos DO BEGIN
      IF debugm THEN
        IF s[i] >= ' ' THEN write(s[i])
        ELSE write('<', ord(s[i]) : 1, '>');
      pause(10);
      putchar(s[i]); i := succ(i); END;
    IF debugm THEN writeln;
    END; (* putmdmstring *)

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

  FUNCTION setbaud(b : baudrate) : boolean;
  (* and change unknown parity/stops to even/1 *)

    VAR
      baud  : integer;

    BEGIN (* setbaud *)
    baud := syscall(sgbaud, 0);      (* preserve known parity/stops *)
    IF mask(baud, 256-64) = 0 THEN baud := baud + 64;     (* 1 stop *)
    IF mask(baud, 64-16) = 0 THEN baud := baud + 48; (* even parity *)
    baud := mask(baud, 256-16) + ord(b);
    setbaud := syscall(sgbaud, baud) = baud;
    END; (* setbaud *)

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

  PROCEDURE setaccess; (* to homdrv/homusr *)

    VAR
      drv, usr, junk  : integer;

    BEGIN (* setaccess *)
    drv := syscall(RSX, ghomdrv) - ord('A');
    usr := syscall(RSX, ghomusr);
    IF drv > 0 THEN BEGIN (* not disabled *)
      poke(4, lsl(usr, 4) + drv);  (* set login for CPM exit *)
      junk := syscall(14, drv);    (* set drive *)
      junk := syscall(32, usr);    (* set user *) END;
    END; (* setaccess *)

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

  PROCEDURE chain(VAR ln : string);
  (* for "chain('xxx')" remove "VAR" above *)

    VAR
      junk, i   : integer;

    BEGIN (* chain *)
    ln[maxstring] := eos;            (* ensure terminated *)
(*$x+,s-,d- illegal pointer, non-std Pascal, save options *)
    junk := syscall(26, pointerto(ln));        (* set DMA *)
(*$x- restore options *)
    junk := syscall(47, 255); (* the chain, and log to du *)
    END; (* chain *)

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

  PROCEDURE initialize;

    VAR
      c      : char;
      trash  : boolean;
      junk   : integer;

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

    PROCEDURE stringset(VAR s : string);
    (* remove trailing blanks and append a <cr> *)

      BEGIN (* stringset *)
      stringdeblank(s); stringextend(s, cr, false);
      END; (* stringset *)

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

    BEGIN (* initialize *)     (* errors terminate operation *)
    IF syscall(RSX, enquire) = 0 THEN error(norsx, 0);
    have2400 := odd(getparm DIV 4);
    debugm := odd(getparm DIV 2);        (* setup modem monitor *)
    setvalue(swrtprotect, -1);           (* write protect everything *)
    writeln(ver, syscall(RSX, rsxversion) : 1, ', by C.B. Falconer');

    (* set critical system state parameters *)
    setvalue(sgstate, 0); setvalue(sgmodemoff, 0);
    setvalue(sgnulls, 0); setvalue(sgtimeout, 0);
    IF syscall(rsx, gomodem) = 0 THEN error(comminit, 0);
    IF have2400 THEN have2400 := setbaud(b2400);
    IF NOT have2400 THEN
      IF NOT setbaud(b1200) THEN error(baudinit, ord(b1200));

    (* following organized to ease in/field patching of strings *)
(*$s-  non-standard        123456789o123456789o12345 *)
    atz     [1 FOR  5] := 'ATZ  ';                atz     [ 6] := eos;
    atnoansw[1 FOR 10] := 'ATS0=0    ';           atnoansw[11] := eos;
    atprime [1 FOR 10] := 'ATE0Q0    ';           atprime [11] := eos;
    atinit  [1 FOR 20] := 'ATE0Q0V0S0=1S2=1M0X1'; atinit  [21] := eos;
    password[1 FOR 20] := 'DDT                 '; password[21] := eos;
    execute [1 FOR 20] := '                    '; execute [21] := eos; 
(*$s+                      123456789o123456789o12345 *)

    stringset(atz);    stringset(atprime);
    stringset(atinit); stringset(atnoansw);
    stringdeblank(execute);

    (* for easy lexical comparisons *)
    stringdeblank(password); stringclean(password);
    END; (* initialize *)

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

  PROCEDURE awaitcall;
  (* times set lower than real, for interpreter execution time *)

    VAR
      ch, ch2, ch3 : char;
      call         : boolean;
      i, t         : integer;

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

    FUNCTION armtoanswer : boolean;
    (* If the modem is already ringing this fouls *)

      VAR
        ch        : char;

      BEGIN (* armtoanswer *)
      armtoanswer := false;
      setvalue(RSX, dskstop);     (* everything off *)
      setvalue(RSX, resetnoise);  (* initially noise suppress off *)
      setaccess;                  (* so initial log-in correct *)
      setvalue(sgstate, 0); setvalue(RSX, stopmodem);
      pause(1000);
      setvalue(RSX, gomodem);
      IF have2400 THEN BEGIN   (* allows removal in BYERSX insert *)
        IF NOT setbaud(b2400) THEN have2400 := false; END;
      IF NOT have2400 THEN
        IF NOT setbaud(b1200) THEN error(baudinit, ord(b1200));
      putmdmstring(atz);
      WHILE expectchar(ch, 300) DO (* nothing, flush port *);
      putmdmstring(atprime);
      WHILE expectchar(ch, 200) DO (* nothing, flush port *);
      putmdmstring(atinit);
      IF NOT expectchar(ch, 1000) THEN writeln('No arm response')
      ELSE IF ch <> '0' THEN writeln('Wrong arm response')
      ELSE IF NOT (expectchar(ch, 100) AND (ch = cr)) THEN
        writeln('No cr after arm')
      ELSE armtoanswer := true;
      END; (* armtoanswer *)

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

    PROCEDURE kill;

      VAR
        ch    : char;

      BEGIN (* kill *)
      setvalue(sgstate, 0); setvalue(RSX, stopmodem);
      setvalue(RSX, resetnoise);  (* initially noise suppress off *)
      writeln('Resetting modem, about 5 sec. delay');
      pause(3000); setvalue(RSX, gomodem);
      putmdmstring(atz); pause(1000);
      putmdmstring(atnoansw);
      WHILE expectchar(ch, 200) DO (* nothing, flush *);
      setvalue(RSX, resetsecure);
      terminate;
      END; (* kill *)

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

    PROCEDURE abortcheck;
    (* PascalP peculiar.  The readln aborts on 1st char = CTRL-C *)

      VAR
        ch    : char;

      BEGIN (* abortcheck *)
      IF odd(lsr(status(input), 1)) THEN BEGIN (* hardware has char *)
        setvalue(RSX, resetsecure); 
        writeln; write('Abort check, hit ret: '); prompt;
        ch := input^; readln;
        IF ch in ['q', 'Q'] THEN kill (* test not reached on CTL-C *)
        ELSE setvalue(RSX, setsecure); END;
      END; (* abortcheck *)

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

    PROCEDURE setrate(b : baudrate);

      BEGIN (* setrate *)
      IF NOT setbaud(b) THEN error(baudinit, ord(b))
      ELSE BEGIN
        CASE b OF
b300:     write(300 : 1);
b1200:    write(1200 : 1);
b2400:    write(2400 : 1);
          END; (* case *)
        write(' baud call'); END;
      END; (* setrate *)

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

    BEGIN (* awaitcall *)
    (* using non-std side effects and evaluation order *)
    REPEAT
      call := false; i := 5; (* arming tries allowed *)
      REPEAT
        IF i < 5 THEN debugm := true;  (* monitor on failure *)
        i := pred(i);
        IF i = 3 THEN have2400 := false;
      UNTIL armtoanswer OR (i < 0);
      IF i < 0 THEN BEGIN
        writeln('Can''t arm modem'); kill; END
      ELSE BEGIN
        WHILE expectchar(ch, 200) DO (* nothing, flush *);
        writeln('Modem armed, awaiting call. "Q" aborts');
        WHILE NOT expectchar(ch, 200) DO abortcheck; (* await ring *)
        writeln;
        IF ch <> '2' THEN writeln('Unexpected response ', ch)
        ELSE IF NOT (expectchar(ch, 500) AND (ch = cr)) THEN
          writeln('No cr after ring')
        ELSE BEGIN
          writeln('Ringing'); i := 100;
          (* In pcd 200 ms timeout below is really over 1 sec *)
          (* This is a totally non-critical value *)
          WHILE (i > 0) AND NOT expectchar(ch, 200) DO BEGIN
            abortcheck; i := pred(i); END;
          writeln;
          IF (i > 0) AND (ch IN ['1', '5']) THEN BEGIN
            ch2 := ' ';
            call := expectchar(ch2, 100);
            WHILE expectchar(ch3, 100) DO (* flush *);
            IF ch = '5' THEN setrate(b1200)
            ELSE IF have2400 THEN
              IF (ch2 = '0') THEN setrate(b2400)
              ELSE setrate(b300)
            ELSE setrate(b300); END
          ELSE write('No carrier');
          writeln; END; (* ringing *)
        END; (* armed *)
    UNTIL call;
    END; (* awaitcall *)

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

  FUNCTION getpassword : boolean;

    VAR
      pwd      : string;
      tries    : integer;
      ok       : boolean;
      pwdfile  : text;

    BEGIN (* getpassword *)
    IF length(password) = 0 THEN getpassword := true
    ELSE BEGIN
      tries := 0; ok := true; pause(1000);
(*$s-*)
      IF debugc THEN reset(pwdfile, 'CON ')   (* for echo/edit *)
      ELSE reset(pwdfile, 'KBD ');            (* no echo, no edit *)
(*$s+*)
      REPEAT
        tries := succ(tries);
        IF NOT ok THEN write('Wrong, '); 
        write('System password : '); prompt;
        readlnstring(pwdfile, pwd);
        setvalue(sgstate, 0);
        write(pwd : length(pwd)); (* local only *)
        IF debugc THEN setvalue(sgstate, remon)
        ELSE setvalue(sgstate, remon + carcks);
        writeln; stringdeblank(pwd);
        stringclean(pwd); stringupshift(pwd);
        ok := pwd = password;
      UNTIL (tries = 3) OR ok;
      getpassword := ok; END;
    END; (* getpassword *)

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

  BEGIN (* answer *)
  initialize;
  REPEAT
    setvalue(RSX, setsecure);   (* prevent abort to CPM *)
    awaitcall;
    IF debugc THEN setvalue(sgstate, remon)
    ELSE setvalue(sgstate, remon + carcks);
    setvalue(sgtimeout, 1);     (* no pass in 1 min kills *)
    pause(2000);                (* for remote to set up *)
  UNTIL getpassword;
  setvalue(sgtimeout, 5);       (* inactivity timeout *)
  IF length(execute) > 0 THEN chain(execute);
  setvalue(RSX, resetsecure);   (* if here exit to CPM *)
  END. (* answer *)