{ PICSKIO.INC - Pascal Integrated Communications System Kernel - I/O routines }
{ 6/11/87 Ver 1.6 Copyright 1987 by Les Archambault}

procedure log(activity: byte; text: FileName);
{ Update log file }
  begin
    seek(logr_file, FileSize(logr_file));
    GetTAD(logr_rec.date);
    logr_rec.action := activity;
    if valid_pw then
      logr_rec.user := user_loc
    else
      logr_rec.user :=0;
    logr_rec.text := text;
    write(logr_file, logr_rec);
    close(logr_file);
    reset(logr_file);
  end;

procedure SetSect(Drive, User: integer);
{ Set to file section }
  begin
    BDOS(seldrive, Drive);
    BDOS(getseluser, User)
  end;

function input_timeout:boolean;
{decrement counter to determine timeout}
  begin
    If (not local_online) then input_time:=input_time-1.0;
    If local_online then input_time:=input_time-0.2; {5 times longer}
    if (not clock) and (frac(int(input_time)/int(lps*0.12))=0.0) then
      begin
        tick_a_sec;
        hour_count:=hour_count+1.666;
      end;
    If input_time<0.0 then
      begin
        Writeln(usr,' +++ Input timed out +++');
        setsect(HomDrv,HomUsr);
        log(13,' ');
        remote_online:=false;
        if local_online then local_online:=false;
        mdhangup;
        input_timeout:=true;
      end
    else
      input_timeout:=false;
  end;

function Online: boolean;
{ Determine whether system is still online - local or remote }

  begin
    if remote_online
      then if ch_carck
             then online := TRUE
             else
               begin
                 putstat('Carrier lost');
                 setsect(homdrv,homusr);
                 log(12,' ');
                 mdhangup;
                 remote_online := FALSE;
                 online := FALSE
               end
      else online := local_online
  end;

procedure PutByte(b: byte);
  begin
    if ch_carck
      then ch_out(b)
  end;

function GetByte(sec: integer; var timeout: boolean): byte;
{ Get byte from modem with 'sec' seconds timeout }
  var
    count: real;
  begin
    count := sec * lps;
    while (not ch_inprdy) and (ch_carck) and (count > 0.0) do
      count := count - 1.0;
    timeout := (not ch_carck) or (count <= 0.0);
    if timeout
      then GetByte := ord(NUL)
      else GetByte := ch_inp
  end;

function GetChar: char;
{ Get character: no wait, no echo }
  var
    ch: char;
  begin
    if keypressed
      then
        begin
          read(KBD, ch);
          if (not online) and (not (ch in [^C, LF, CR,FF]))
            then ch := NUL;
          case ch of
            ^W: begin
                  op_chat := TRUE;
                  ch := ' '
                end;
            ^E: begin
                  remote_copy := not remote_copy;
                  if remote_copy
                    then putstat('Remote copy on')
                    else putstat('Remote copy off');
                  ch := NUL
                end;
            ^R: begin
                  delay_down := not delay_down;
                  if delay_down
                    then putstat('Delayed shutdown on')
                    else putstat('Delayed shutdown off');
                  ch := NUL
                end;
            ^T: begin
                  remote_online := FALSE;
                  mdhangup;
                  ch := NUL
                end;
            LF: begin
                  if online
                    then putstat('^W: CHAT, ^E: Remote copy on/off, ^R: Remote offline - delayed, ^T: Twit')
                    else putstat('^C: Shutdown PICS, ^L: Local use');
                  if online then ch := NUL;
                end
          end
        end
    else if remote_online and remote_copy and ch_carck and ch_inprdy
      then ch := chr($7F and ch_inp)
      else ch := NUL;
    GetChar := ch
  end;

function brk: boolean;
{ Check for break or pause }
  var
    test:boolean;
    ch: char;
  begin
  if (not abort) then
   begin
    input_time:=timeout * lps * 0.125;      {set input timer with speed adjust}
    ch := GetChar;
    if ch = DC3 then                       { ^S }
      repeat
        ch := GetChar
      until (not online) or (ch <> NUL) or (input_timeout);
    test:= (not online) or (ch = ETX) or (ch=#$0B);  { ^C or ^K }
    if test then
      begin
      mult_cmds:=false; cmd_queue:='';
      end;
    brk:=test;
   end
   else
    begin
     abort:=false;
     brk:=true;
    end;
  end;

procedure PutChar(ch: char);
{ User written I/O driver to output character }
  var
    i: integer;
  begin
    if user_rec.shift_lock
      then ch := UpCase(ch);
    if printer_copy
      then BDOS(5, ord(ch));
    if (online)
      then
        begin
          if (ch <> BEL) or local_online
            then BDOS(6, ord(ch));
          if remote_copy
            then
              begin
                ch_out($7F and ord(ch));
                if ch = CR
                  then for i := 1 to user_rec.nulls do
                    ch_out(ord(NUL));
                if ch = LF
                  then for i := 1 to (user_rec.nulls shr 2) do
                    ch_out(ord(NUL))
              end
        end
  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 = [' '..'~'];
  var
    auto, echo, shiftlock, wrap, question: boolean;
    i, len, cursor: integer;
  begin
    if user_rec.columns < maxlen
      then maxlen := user_rec.columns;
    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 }
    wrap      := (pos('W', mode) > 0);      { Word wrap }
    question  := (pos('?', mode) > 0);      { Force inpstr := '?' when encountered }
    auto := auto or wrap;                   { Wrap forces auto on }
    len := length(inpstr);
    cursor := succ(len);
    if echo and (cursor > 0)
      then Write(USR, inpstr);
    repeat
      input_time:=timeout * lps * 0.125;   { This loop is slower than GetByte }
      repeat
      ch := GetChar;
      until (not online) or (ch <> NUL) or (input_timeout);
      if shiftlock
        then ch := UpCase(ch);
      case ch of
        TAB:
          repeat
            if echo
              then Write(USR, ' ');
            cursor := succ(cursor);
            insert(' ', inpstr, cursor)
          until (0 = cursor mod 5) or (cursor >= maxlen);
        RUB, BS:
          if cursor > 1
            then
              begin
                Write(USR, BS, ' ', BS);
                cursor := pred(cursor);
                delete(inpstr, cursor, 1)
              end;
        CAN:
          while cursor > 1 do
            begin
              Write(USR, BS, ' ', BS);
              cursor := pred(cursor);
              delete(inpstr, cursor, 1)
            end;
        ^A:
          while cursor > 1 do
            begin
              if echo
                then Write(USR, BS);
              cursor := pred(cursor)
            end;
        ^S:
          if cursor > 1
            then
              begin
                if echo
                  then Write(USR, BS);
                cursor := pred(cursor)
              end;
        ^D:
          if cursor <= length(inpstr)
            then
              begin
                if echo
                  then Write(USR, inpstr[cursor]);
                cursor := succ(cursor)
              end;
        ^F:
          while cursor <= length(inpstr) do
            begin
              if echo
                then Write(USR, inpstr[cursor]);
              cursor := succ(cursor)
            end;
        ^G:
          if cursor <= length(inpstr)
            then delete(inpstr, cursor, 1);
        else
          if (ch in dispset) and ((len < maxlen) or auto)
            then
              begin
                if echo
                  then Write(USR, ch)
                   else write(usr,'.');
                if (ch = '?') and question and (len=1)
                  then
                    begin
                      inpstr := ch;
                      ch := CR
                    end
                  else
                    begin
                      insert(ch, inpstr, cursor);
                      cursor := succ(cursor)
                    end
              end
      end;
      len := length(inpstr)
    until (not online) or (ch in termset) or ((len >= maxlen) and auto);
    next_inpstr := '';
    if wrap and (len >= maxlen)
      then
        begin
          while (inpstr[len] <> ' ') and (len > 1) do
            len := pred(len);
          if len > 1
            then
              begin
                if echo
                  then
                    begin
                      for i := succ(len) to length(inpstr) do
                        Write(USR, BS);
                      for i := succ(len) to length(inpstr) do
                        Write(USR, ' ')
                    end;
                next_inpstr := copy(inpstr, succ(len), length(inpstr));
                inpstr := copy(inpstr, 1, pred(len))
              end
        end
  end;

procedure pause;
{ Pause for user response before continuing }
  var ch:char;
  begin
    input_time:=timeout * lps * 0.125;        {set timer with speed adjust}
    Write(USR, 'Press any key to continue...');
    if user_rec.noisy
      then Write(USR, BEL);
    repeat
    ch:=GetChar;
    if (ch=ETX) or (ch=#$0B) or (upcase(ch)='K') then abort:=true;
    until (not online) or (ch <> NUL) or (input_timeout);
    Write(USR, CR, ' ':28, CR)
  end;

function prompt(pr: StrPr; len: integer; mode: Str10): StrStd;
{ Prompt user, return string and process multiple command buffer }
  type
    charset = set of char;
  const
    delim_set:charset = [';',' ',','];
  var
    i, j: integer;
    reply,buffer: StrStd;
    t:tad_array;
  begin
    reply := ''; buffer:=''; ch:=' ';
    If (not mult_cmds) or (pos('L',mode)>0) then  {L for literal}
      begin
        Write(USR, pr);
        if pos('M',mode)>0 then
          Write(USR, ' [press "?" for menu]');
        Write(USR, '> ');
        if user_rec.noisy
          then Write(USR, BEL);
        if (macro_in_progress) and (macro_file_exists) then
          begin
            buffer:=''; ch:=' ';
            while (not eof(macro_file)) and (length(buffer)=0) do
              begin
                ch:=' ';
                readln(macro_file,buffer);
                i:=1; j:=length(buffer);
                while (j>0) and (i<=j) do
                  begin  {remove rest of line after first delimeter found}
                    if buffer[i] in delim_set then delete(buffer,i,j-(i-1));
                    j:=length(buffer); i:=succ(i);
                  end;
                if length(buffer)>0 then
                  begin
                   if pos('S',mode)>0 then for i:=1 to length(buffer) do
                    buffer[i]:=upcase(buffer[i]);
                    if (buffer='^M') or (buffer='^m') then
                      begin
                        buffer:=chr(13);
                        ch:=chr(13);
                      end
                    else
                    ch:=Upcase(buffer[1]);
                    write(buffer);
                  end;
              end;    {reading macro file}
            if eof(macro_file) then
              begin
                macro_in_progress:=false;
                gettad(t);
                macro_done:=t[3];
              end;
          end
        else
        GetStr(buffer, ch, len, mode);
      end
    else
      buffer:=cmd_queue;     {feed in from queue}
    If pos('L',mode)=0 then  {not literal, process mult. commands}
      begin
        i:=0; j:=0;
        repeat
          i:=succ(i);
          if (pos('N',mode)>0) and (buffer[i]=' ') then i:=succ(i);
          if buffer[i] in delim_set then j:=i;
        until (i>=length(buffer)) or (buffer[i] in delim_set);
        if j>0 then
          begin
            mult_cmds:=true;
            reply:=copy(buffer,1,j-1);    {get command from buffer}
            delete(buffer,1,j);           {remove cmd and delimeter}
            if buffer='' then
              begin
                mult_cmds:=false;  cmd_queue:='';
              end
            else
            cmd_queue:=buffer;            {save balance for next command}
            if reply='' then reply:=' ';
            if macro_in_progress and (reply=chr(13)) then reply:=' ';
          end
        else
          begin
            mult_cmds:=false;
            cmd_queue:='';
            reply:=buffer;               {for single commands}
            if reply='' then reply:=' '; {so we wont bomb ch assignments}
            if macro_in_progress and (reply=chr(13)) then reply:=' ';
          end;
      end       {not literal}
    else
      begin     {literal}
        reply:=buffer;
        mult_cmds:=false;
        cmd_queue:='';
      end;
    writeln(usr);
    prompt:=reply;
  end; {prompt}

function ask(pr: StrPr): boolean;
{ Ask yes-or-no question and return TRUE for 'Y', FALSE otherwise }
  var
    ch: char;
  begin
    if user_rec.noisy
      then Write(USR, BEL);
    repeat
      ch:=copy(prompt(pr+' [Y/N] ? >',1,'ES'),1,1);
    until (ch in ['Y','N',' ']) or (not online);
    if ch='Y' then ask:=true
    else ask:=false;
  end;

 {end of PICSkio.inc }