{ ROSKER.INC - Remote Operating System Kernel }

function online: boolean;
{ Determine whether system is still online - local or remote }
  begin
    if remote_online
      then if mdcarck
             then online := TRUE
             else
               begin
                 mdhangup;
                 writeln;
                 writeln('Carrier lost.');
                 remote_online := FALSE;
                 online := FALSE
               end
      else online := local_online
  end;

procedure putchar(ch: char);
{ User written I/O driver to output character }
  var
    i: integer;
  begin
    if not user_rec.case_sw
      then ch := UpCase(ch);
    if printer_copy
      then BDOS(5, ord(ch));
    if local_online
      then BDOS(6, ord(ch))
    else if online
      then
        begin
          if ch <> BEL
            then BDOS(6, ord(ch));
          if remote_copy
            then
              begin
                mdout($7F and ord(ch));
                if ch = CR
                  then for i := 1 to user_rec.nulls do
                    mdout(ord(NUL))
              end
        end
  end;
{ ROS Chat modification }

{ This procedure will allow a chat function from the main ROS
system without any troubles.  Just add a ^T sysop control
function and have it call this procedure.  Insert this module
right after the Putln procedure in the ROSKER.INC file.  Then
insert the modification ROSCHT1.MOD in the GetChr procedure
right after the ^W command.  }

{ Bruce Childers 04/09/85 Sysop of CIT, 703-281-7907 300/1200bps }

procedure talk;

const
 back_space  =   #8' '#8;       { Backspace & DEL conversion  }
 Wrap_start  =   70.0;          { Auto Wrap starts here       }
 Wrap        =   78.0;          { Must Wrap now--max len line }

var
 ch: char;                      { Input character  }
 count: real;                   { Position counter }

begin
  count := 1.0;                 { Start at Pos = 1 }
  ch := NUL;                    { Clear it         }

  { Main loop, monitor for ETX or not online }
  repeat

    { Wait for a character to get or not online }
    repeat
    until (mdinprdy) or (keypressed) or (not online);

    { Try to get character from modem first }
    if mdinprdy and online
      then
          ch := chr($7F and mdinp)
      else
       if online
         then
          read(KBD,ch);


    { Input character is a backspace, convert it and fix count }
    if (ch = #8) and (count > 1.0) and (online)
      then
        begin
          WRITE(USR, back_space);
          count := count - 1.0
        end;

     { Input character is a del (127), convert it and fix count }
     if (ch = #127) and (count > 1.0) and (online)
       then
         begin
           WRITE(USR, back_space);
           count := count - 1.0
         end;

     { CR, convert to CR/LF sequence and fix count }
     if (ch = #13) and (online)
       then
         begin
           WRITELN(USR, '');
           count := 1.0
         end;

     { LF, convert to CR/LF sequence and fix count }
     if (ch = #10) and (online)
       then
         begin
           WRITELN(USR,'');
           count := 1.0
         end;

     { Standard Character, echo it, update count, auto wrap }
     if (ch > #31) and (ch < #127) and (online)
       then
         begin
          WRITE(USR, ch);
          count := count + 1.0;
          if (count > Wrap_start) and (online)       { Up around wrap time }
            then
              begin
                if (ch = #32) and (online)      { Space and Auto Wrap }
                  then
                    begin
                      WRITELN(USR, '');
                      count := 1.0;
                    end;
                if (count > Wrap) and (online)  { Have to wrap now }
                  then
                    begin
                      WRITELN(USR, '');
                      count := 1.0;
                    end;
              end;
      end;
  until (ch = ETX) or (not online);
end;


function GetChar: char;
{ Get character, no echo }
  var
    ch: char;
  begin
    ch := NUL;
    if keypressed
      then
        begin
          read(KBD, ch);
          case ch of
            ^B: begin
                  remote_copy := not remote_copy;
                  if remote_copy
                    then
                      begin
                        putstat('Remote copy on.');
                        user_rec.access := temp_access
                      end
                    else
                      begin
                        putstat('Remote copy off.');
                        temp_access := user_rec.access;
                        user_rec.access := 255
                      end;
                  ch := NUL
                end;
            ^D: begin
                  putstat('Delayed shutdown requested.');
                  delay_down := TRUE;
                  ch := NUL
                end;
            ^N: begin
                  putstat('Remote session terminated.');
                  remote_online := FALSE;
                  ch := NUL
                end;
            ^W: begin
                  putstat(user_rec.fn + ' ' + user_rec.ln + ' from ' + user_rec.ad);
                  ch := NUL
                end;
	{ ROS Chat Modification File #2 }

{ Pull this file in at the end of the ^W case statement in the
GetChr procedure located in the ROSKER.INC file.  Be sure to put
a ';' at the 'end' statement with th ^W case area. }

{ Bruce Childers 04/09/85 Sysop of CIT 24 hrs 703-281-7907 }

          ^T: begin
                writeln(USR, CR,LF,LF);
         writeln(USR,'Sysop Chat - User ',user_rec.fn, ' ', user_rec.ln);
                WRITELN(USR, CR+LF+LF+BEL+'**** Sysop Interrupt ****'+CR+LF);
                talk;
                WRITELN(USR, CR+LF+LF+'Returning to previous function'+CR+LF);
                WRITELN(USR, CR);
              ch := NUL
              end;
            LF: begin
                  if online
                    then putstat('^B: Blank remote, ^D: Delayed shutdown, ^N: Twit, ^T: Sysop interrupt, ^W: Who')
                    else putstat('^C: Shutdown ROS, <RETURN>: Local use');
                  ch := NUL
                end
          end
        end
    else if remote_online and remote_copy and mdcarck and mdinprdy
           then ch := chr($7F and mdinp);
    GetChar := ch
  end;

procedure GetStr(var inpstr: StrStd; var ch: char; maxlen: integer; mode: Str10);
{ Get a valid input string from the user }
  type
    charset = set of char;
  const
    editset: charset = [BS, RUB, CAN, TAB];
    termset: charset = [LF, CR, ETX];
    dispset: charset = [NUL, ' '..'~'];
  var
    auto, echo, shiftlock: boolean;
    i, len: integer;
    count: real;
  begin
    auto      := (pos('A', mode) > 0);      { Line complete when full }
    echo      := (pos('E', mode) > 0);      { Display characters on entry }
    shiftlock := (pos('S', mode) > 0);      { Make all characters upper case }
    inpstr := '';
    len := 0;
    repeat
      count := timeout * lps;
      repeat
        ch := GetChar;
        if remote_online
          then count := count - 1.0
      until (not online) or (ch <> NUL) or (count < 0.0);
      if count < 0.0
        then
          begin
            writeln(USR, '-=[ INPUT TIMED OUT ]=-', BEL, BEL);
            remote_online := FALSE
          end;
      if shiftlock
        then ch := UpCase(ch);
      if (ch in dispset) and (len <= maxlen)
        then
          begin
            inpstr := inpstr + ch;
            if echo
              then write(USR, ch)
          end
      else if ch = TAB
        then
          repeat
            inpstr := inpstr + ' ';
            if echo
              then write(USR, ' ')
          until (0 = length(inpstr) mod 8) or (length(inpstr) >= maxlen)
      else if ((ch = RUB) or (ch = BS)) and (len > 0)
        then
          begin
            delete(inpstr, len, 1);
            if echo
              then write(USR, BS, ' ', BS)
          end
      else if ch = CAN
        then
          begin
            inpstr := '';
            if echo
              then for i := 1 to len do
                     write(USR, BS, ' ', BS)
          end;
      len := length(inpstr)
    until (not online) or (ch in termset) or ((len >= maxlen) and auto)
          or ((ch = ' ') and (len >= (maxlen - 6)) and auto)
  end;

function brk: boolean;
{ Check for break or pause }
  var
    ch: char;
  begin
    ch := GetChar;
    while ch = DC3 do                       { ^S }
      repeat
        ch := GetChar
      until (not online) or (ch <> NUL);
    brk := (not online) or (ch = ETX)       { ^C }
  end;

function prompt(st: StrPr; len: integer; mode: Str10): StrStd;
{ Prompt user and get response }
  var
    ch: char;
    reply: StrStd;
  begin
    write(USR, st);
    if noisy
      then write(USR, BEL);
    GetStr(reply, ch, len, mode);
    prompt := reply
  end;

function select(pr: StrPr; st: StrStd): char;
{ Prompt user and get single character response }
  var
    i, j: integer;
    ch: char;
  begin
    pr := prompt(pr + ' ', 1, 'AS') + ' ';
    ch := pr[1];
    i := pos(ch, st);
    if i > 0
      then
        begin
          j := i;
          repeat
            j := succ(j)
          until (j > length(st)) or (st[j] in ['A'..'Z']);
          writeln(USR, copy(st, i, j - i))
        end
      else writeln(USR, ch);
    select := ch
  end;

function ask(st: StrPr): boolean;
{ Ask yes-or-no question and return TRUE for 'Y', FALSE otherwise }
  begin
    ask := ('Y' = select(st + ' <y/n>?', 'YesNo'))
  end;

procedure pause;
{ Pause for user response before continuing }
  var
    st: string[1];
  begin
    st := prompt('Press <RETURN> to continue...', 1, '');
    write(USR, CR, ' ':29, CR)
  end;

function trim(st: StrStd): StrStd;
{ Remove leading and trailing blanks }
  var
   i, j: integer;
  begin
    i := 1;
    j := length(st);
    while (st[i] = ' ') and (i <= j) do
      i := succ(i);
    while (st[j] = ' ') and (j >= i) do
      j := pred(j);
    trim := copy(st, i, j - i + 1)
  end;

function compress(st: StrStd): StrStd;
{ Remove ALL blanks and nulls }
  var
    i: integer;
  begin
    repeat
      i := pos(' ', st);
      if i > 0
        then delete(st, i, 1)
    until i = 0;
    repeat
      i := pos(NUL, st);
      if i > 0
        then delete(st, i, 1)
    until i = 0;
    compress := st
  end;

function pad(st: StrStd; i: integer): StrStd;
{ Pad string with spaces to length of i }
  begin
    while length(st) < i do
      st := st + ' ';
    pad := st
  end;

function intstr(n, w: integer): Str10;
{ Return a string value (width 'w')for the input integer ('n') }
  var
    st: Str10;
  begin
    str(n:w, st);
    intstr := st
  end;

function strint(st: Str10): integer;
{ Convert string to integer }
  var
    x, code: integer;
  begin
    if st[1] = '+'
      then delete(st, 1, 1);
    if st = ''
      then code := 1
      else val(st, x, code);
    if code = 0
      then strint := x
      else strint := 0                      { Error, return with 0 }
  end;

function FormTAD(t: tad_array): StrTAD;
  const
    day: array [0..6] of string[6] =
      ('Sun','Mon','Tues','Wednes','Thurs','Fri','Satur');
    month: array [1..12] of string[3] =
      ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
  var
    i: integer;
    line: StrTAD;

  function zeller(day, month, year: integer): integer;
  { Compute the day of the week using Zeller's Congruence }
    var
      century: integer;
    begin
      if month > 2
        then month := month - 2
        else
          begin
            month := month + 10;
            year := year - 1
          end;
      century := year div 100;
      year := year mod 100;
      zeller := (day - 1 + ((13 * month - 1) div 5) + (5 * year div 4) +
                century div 4 - 2 * century + 1) mod 7
    end;

  begin { FormTAD }
    line := intstr(t[2], 2) + ':' + intstr(t[1], 2);
    for i:= 1 to length(line) do
      if line[i] = ' '
        then line[i]:= '0';
    if t[4] > 0
      then FormTAD :=
        line + '  ' +
        day[zeller(t[3], t[4], t[5] + 1900)] + 'day  ' +
        intstr(t[3], 2) + '-' + month[t[4]] + '-' + intstr(t[5], 2)
      else FormTAD := ''
  end;

procedure mesg_insert(TypMsg: byte);
{ Insert message into linked list }
  var
    here: MesgPtr;
  begin
    new(here);
    if MesgBase = nil
      then MesgBase := here
      else MesgLast^.next := here;
    MesgLast := here;
    MesgLast^.MesgNo := summ_rec.summ_num;
    MesgLast^.SummLoc := pred(FilePos(summ_file));
    MesgLast^.TypMsg := TypMsg;
    MesgLast^.next := nil
  end;

procedure mesg_find(num: integer);
{ Find message in linked list }
  begin
    MesgCurr := MesgBase;
    while (MesgCurr <> nil) and (MesgCurr^.MesgNo < num) do
      MesgCurr := MesgCurr^.next
  end;

procedure send_time(size: integer; var mm, ss: integer);
{ Compute file send time }
  var
    tr_time: real;
  begin
    tr_time := rate * size;
    mm := trunc(tr_time);
    ss := round(60.0 * frac(tr_time))
  end;

procedure log(activity: byte; text: FileName);
{ Write activity, time, and text to log file }
  begin
    seek(logr_file, FileSize(logr_file));
    GetTAD(logr_rec.time_stamp);
    logr_rec.action := activity;
    logr_rec.user := user_loc;
    logr_rec.text := text;
    write(logr_file, logr_rec)
  end;

procedure InsertFile(fname: name_array; index, size: integer;
                     var entries: integer; var first: FilePtr);
{ Insert a new file name into an alphabetic list }
  var
    f,                                      { File name entry being created }
    this, last: FilePtr;                    { Followers for insertion }
    fn: FileName;
  begin
    fn := '           ';                    { Initialize string }
    move(fname, fn[1], 11);                 { Move name into place }
    insert('.', fn, 9);
    last := nil;
    this := first;
    while (this <> nil) and (this^.fname < fn) do
      begin
        last := this;
        this := this^.next
      end;
    if this^.fname <> fn
      then
        begin
          entries := succ(entries);
          new(f);
          f^.fname := fn;
          f^.index := index;
          f^.fsize := size;
          f^.next  := this;
          if last = nil
            then first := f
            else last^.next := f
        end
    else if (this^.fname = fn) and (this^.fsize < size)
      then this^.fsize := size
  end;