CP/M/CPM_CDROM.iso/mbug/mbug184.arc/ROS34.LBR/ROSKIO.IZC/ROSKIO.INC

Text File | 1979-12-31 | 11KB | 382 lines

{ ROSKIO.INC - Remote Operating System Kernel - I/O routines }

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');
                 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;

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;

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]))
            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 ROS, [C/R]: Local use');
                  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;

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;
    count: real;
  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
      count := timeout * lps * 0.574;       { This loop is slower than GetByte }
      repeat
        if (0 < macro_ptr) and (macro_ptr <= length(macro))
          then
            begin
              ch := macro[macro_ptr];
              if ch = '/'
                then ch := CR;
              macro_ptr := succ(macro_ptr)
            end
          else 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;
            mdhangup
          end;
      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
                if echo
                  then Write(USR, BS, ' ', BS);
                cursor := pred(cursor);
                delete(inpstr, cursor, 1)
              end;
        CAN:
          while cursor > 1 do
            begin
              if echo
                then 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);
                if (ch = '?') and question
                  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;

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;

procedure pause;
{ Pause for user response before continuing }
  begin
    Write(USR, 'Press any key to continue...');
    if user_rec.noisy
      then Write(USR, BEL);
    repeat
    until (not online) or (GetChar <> NUL);
    Write(USR, CR, ' ':28, CR)
  end;

function ask(pr: StrPr): boolean;
{ Ask yes-or-no question and return TRUE for 'Y', FALSE otherwise }
  var
    ch: char;
    reply: StrStd;
  begin
    reply := '';
    Write(USR, pr, ' [y/n]?> ');
    if user_rec.noisy
      then Write(USR, BEL);
    GetStr(reply, ch, 1, 'AS');
    if reply = 'Y'
      then
        begin
          Writeln(USR, 'Yes');
          ask := TRUE
        end
      else
        begin
          Writeln(USR, 'No');
          ask := FALSE
        end
  end;

function prompt(pr: StrPr; len: integer; mode: Str10): StrStd;
{ Prompt user and get response }
  var
    ch: char;
    reply: StrStd;
  begin
    reply := '';
    Write(USR, pr, '> ');
    if user_rec.noisy
      then Write(USR, BEL);
    GetStr(reply, ch, len, mode);
    Writeln(USR);
    prompt := reply
  end;

function select(pr: StrPr; st: Str100): char;
{ Prompt user and get single character response }
  var
    ch: char;
    i, j: integer;
    reply: StrStd;
  begin
    reply := '';
    Write(USR, pr);
    if user_rec.help_level > 1
      then Write(USR, ' [press "?" for menu]');
    Write(USR, '> ');
    if user_rec.noisy
      then Write(USR, BEL);
    GetStr(reply, ch, 1, 'AS');
    if reply = ''
      then ch := ' '
      else ch := reply;
    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 getc(var inp_file: untype_file; var BufferPtr, remaining: integer): integer;
  { Get an 8 bit value from the input buffer - read block if necessary }
    var
      NoOfRecs: integer;
    begin
      if BufferPtr > BufSize
        then
          begin
            if BufBlocks < remaining
              then NoOfRecs := BufBlocks
              else NoOfRecs := remaining;
            if NoOfRecs > 0
              then BlockRead(inp_file, Buffer, NoOfRecs);
            remaining := remaining - NoOfRecs;
            BufferPtr := 1
          end;
      getc := Buffer[BufferPtr];
      BufferPtr := succ(BufferPtr)
    end;