Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/PASCAL.ZIP/TERMNL.PAS

Pascal/Delphi Source File | 1980-01-01 | 41.2 KB | 1,299 lines

{$C-}
{$V-}

program terminal;  {This is a terminal handling package by Jim Nutt
                    CIS - 71076,1434 or EIS - 76044,1155.
                    It is public domain and not to be sold
                    vidtex compatible
                    CIS-A file transfers}

{$u-}  {Serial I/O drivers start here}

Const
     RECV_BUF_SIZE = 4096;             {this may be changed to
                                        whatever size you need}
    DEFAULT_BAUD   = 1200;
{ *** Port addresses *** }
     THR = $3F8;                       {Transmitter Holding Register: the
                                        serial port address we use to send
                                        data}
     IER = $3F9;                       {Interrupt Enable Register for the
                                        serial port}
     LCR = $3FB;                       {Line Control Register for the serial
                                        port. Determines data bits, stop bits
                                        and parity, contributes to setting
                                        baud-rate}
     MCR = $3FC;                       {Modem Control Register}
     LSR = $3FD;                       {Line Status Register}
     MSR = $3FE;                       {Modem Status Register}
     IMR = $021;                       {Interrupt Mask Register port address
                                        of Intel 8259A Programmable Interrupt
                                        controller}
{ *** Masks *** }
     ENABLE_OUT2 = 8;                  {Setting bit 3 of MCR enables OUT2}
     ENABLE_DAV = 1;                   {Setting bit 0 of IER enables Data
                                        AVailable interrupt from serial port}
     ENABLE_IRQ4 = $EF;                {Clearing bit 5 of IMR enables serial
                                        interrupts to reach the CPU}
     DISABLE_OUT2 = 1;                 {Clearing MCR disables OUT2}
     DISABLE_DAV = 0;                  {Clearing IER disables Data
                                       AVailable interrupt from serial port}
     DISABLE_IRQ4 = $10;               {Setting bit 5 of IMR stops serial
                                        interrupts from reaching the CPU}
     SET_BAUD = $80;                   {Setting bit 7 of LCR allows us to set
                                        the baud rate of the serial port}
     SET_PARMS = $7F;                  {Clearing bit 7 of LCR allows us to set
                                        non-baud-rate parameters on the
                                        serial port}

Type
    parity_set        = (none,even);    {readability and expansion}
    bigstring        = string[80];

Var
   buf_start, buf_end    : integer;    {NOTE: these will change by them-
                                        selves in the background}
   recv_buffer           : array [1..RECV_BUF_SIZE] of byte;
                                       {also self-changing}
   speed                 : integer;    {I don't know the top speed these
                                        routines will handle}
   dbits                 : 7..8;       {only ones most people use}
   stop_bits             : 1..2;       {does anyone use 2?}
   parity                : parity_set;  {even and none are the common ones}

function cgetc(TimeLimit : integer) : integer;
{if a byte is recieved at COM1: in less than TimeLimit seconds,
 returns byte as an integer, else returns -1}

const
     TIMED_OUT = -1;
begin
     TimeLimit := TimeLimit shl 10;     {convert TimeLimit to millisecs}
     while (buf_start = buf_end) and (TimeLimit > 0) do
       begin
          delay(1);
          TimeLimit := pred(TimeLimit)
       end;
     if (TimeLimit >= 0) and (buf_start <> buf_end)
       then
         begin
           inline ($FA);            {suspend interrupts}
           cgetc := recv_buffer[buf_start];
           buf_start := succ(buf_start);
           if buf_start > RECV_BUF_SIZE
             then
               buf_start := 1;
           inline ($FB);            {resume interrupts}
         end
       else
         cgetc := TIMED_OUT;
end;

procedure send(c : byte);

var
   a : byte;
begin
  repeat
       a := port[LSR]
  until odd(a shr 5);
  port[THR] := c;
end;

procedure StrSend(s : bigstring);

var
   i : integer;
begin
     for i := 1 to length(s) do
         begin
           send(ord(s[i]));
           delay(10);
         end
end;

procedure SendPaced(s : bigstring);

label
     99;

const
     CRSYM = '<';

var
   i : integer;
   c : integer;
begin
     for i := 1 to Length(s) do
       begin
          if s[i] = CRSYM
            then
              send(13)
            else
              send(ord(s[i]));
          c := cgetc(1);
          if c <> -1
            then
              write(chr(c))
            else begin
                   sound(440);
                   delay(20);
                   nosound;
                   goto 99
              end
       end;
  99:
end;

{Communications routines for TURBO Pascal written by Alan Bishop,
 modified slightly by Scott Murphy.
 Handles standart COM1: ports with interrupt handling.  Includes
 support for only one port, and with no overflow, parity, or other
 such checking.  However, even some of the best communication programs
 don't do this anyway, and I never use it.  If you make modifications,
 please send me a copy if you have a simple way of doing it (CIS EMAIL,
 Usenet, MCI Mail, etc)  Hope these are useful.

Alan Bishop - CIS      - 72405,647
              Usenet   - bishop@ecsvax
              MCI Mail - ABISHOP
}

procedure update_uart;
{uses dbits, stop_bits, and parity}

var
   newparm, oldLCR : byte;
begin
  newparm := dbits-5;
  if stop_bits = 2
    then newparm := newparm + 4;
  if parity = even
    then newparm := newparm + 24;
  oldLCR := port[LCR];
  port[LCR] := oldLCR and SET_PARMS;
  port[LCR] := newparm;
end;


procedure term_ready(state : boolean);
{if state = TRUE then set RTS true else set false}

var
   OldMCR : byte;
begin
     OldMCR := port[MCR];
     if state
       then
         port[MCR] := OldMCR or 1
       else
         port[MCR] := OldMCR and $FE
end;

function carrier : boolean;
{true if carrier, false if not}
begin
  carrier := odd(port[MSR] shr 7);
end;

procedure set_up_recv_buffer;
begin
  buf_start := 1;
  buf_end   := 1;
end;

procedure new_baud(rate : integer);
{has no problems with non-standard bauds}

var
   OldLCR : byte;
begin
  if rate <= 9600
    then
      begin
        speed := rate;
        rate := trunc(115200.0/rate);
        OldLCR := port[LCR] or SET_BAUD;
        port[LCR] := OldLCR;
        port[THR] := lo(rate);
        port[IER] := hi(rate);
        port[LCR] := OldLCR and SET_PARMS;
      end;
end;

procedure init_port;
{installs interrupt sevice routine for serial port}

var a,b : integer;
    buf_len : integer;
begin
  update_uart;
  new_baud(speed);
  buf_len := RECV_BUF_SIZE;

 {this is the background routine}

  inline (
              $1E/                     {push ds}
              $0E/                     {push cs}
              $1F/                     {pop  ds                  ;ds := cs}
              $BA/*+23/                {mov  dx, offset ISR}
              $B8/$0C/$25/             {mov  ax, 250CH           ;set COM1: vector}
      {f_len}
              $89/$3E/*+87/            {mov  lcl_buf_len,di}
              $1F/                     {pop  ds}
              $2E/$8C/$1E/*+83/        {mov  lcl_ds, ds}
              $EB/$51/                 {jmp  exit}
{ISR:}        $FB/                     {sti}
              $1E/                     {push ds}
              $50/                     {push ax}
              $53/                     {push bx}
              $52/                     {push dx}
              $56/                     {push si}
              $2E/$8E/$1E/*+70/        {mov  ds,[lcl_ds]}
              $BA/$F8/$03/             {mov  dx, 3F8H           ;address RBR}
              $EC/                     {in   al, dx             ;read rbr}
              $BE/RECV_BUFFER/
          {mov  si, recv_buffer    ;address start of recv_buffer}
              $8B/$1E/BUF_END/
          {mov  bx, [buf_end]      ;index of current char in recv_buffer}
              $88/$40/$FF/             {mov  [bx+si-1],al       ;copy char to recv_buffer}
              $43/                     {inc  bx                 ;update buf_end}
              $E8/$22/$00/             {call adj_idx}
              $89/$1E/BUF_END/         {mov  [buf_end],bx}
              $3B/$1E/BUF_START/       {cmp  bx, [buf_start]}
              $75/$0C/                 {jnz  ISR_DONE}
              $8B/$1E/BUF_START/       {mov  bx,buf_start}
              $43/                     {inc  bx}
              $E8/$10/$00/             {call adj_idx}
              $89/$1E/BUF_START/       {mov  [buf_start],bx}
              $BA/$20/$00/             {mov  dx,20H            ;EOI command for 8259A PIC}
              $B0/$20/                 {mov  al,20H            ;EOI port for 8259A PIC}
              $EE/                     {out  dx,al             ;End Of Interrupt}
              $5E/                     {pop  si}
              $5A/                     {pop  dx}
              $5B/                     {pop  bx}
              $58/                     {pop  ax}
              $1F/                     {pop  ds}
              $CF/                     {iret}
{adj_idx:}    $2E/$8B/$16/*+11/        {mov  dx,[lcl_buf_len]}
              $42/                     {inc  dx}
              $39/$DA/                 {cmp  dx,bx}
              $75/$03/                 {jnz  no_change}
              $BB/$01/$00/             {mov  bx,1}
{no_change:}  $C3/                     {ret}
{lcl_buf_len;}$00/$00/                 {dw  0}
              $00/$01/                 {dw  1}
{exit:}       $90                      {nop}
  );
  port[IER] := ENABLE_DAV;              {interrupt enable}
  a := port[MCR];
  port[MCR] := a or ENABLE_OUT2;        {preserve RTS and enable OUT2}
  a := port[IMR];
  a := a and ENABLE_IRQ4;
  port[IMR]  := a;
end;


procedure remove_port;
{disables DAV, OUT2 and IRQ4 so that COM1: will no longer be serviced}

var
   a : byte;
begin
     a         := port[IMR];
     port[IMR] := a or DISABLE_IRQ4;
     port[IER] := DISABLE_DAV;
     a         := port[MCR];
     port[MCR] := a and DISABLE_OUT2;
end;


procedure break;
{send a break}

var a,b : byte;
begin
  a := port[LCR];
  b := (a and $7F) or $40;
  port[LCR] := b;
  delay(400);
  port[LCR] := a;
end;

procedure setup;
{initialize most stuff - you may want to replace this routine completely}
begin
  dbits        := 8;
  parity       := none;
  stop_bits    := 1;
  speed        := DEFAULT_BAUD;
  init_port;
  term_ready(true);
end;
{$u+}

const
  minint = -32767;

type
  buftype = array[0..520] of char;
  bigbuf  = array[minint..maxint] of byte;
  wstr    = string[60];

var
  parms       : wstr;
  tstr        : wstr;
  number      : wstr;
  old_carrier : boolean;
  ch          : char;
  exit        : boolean;
  rcvd        : integer;
  save        : boolean;
  buffer      : ^bigbuf;
  buffptr     : integer;
  i,j         : integer;
  blocks      : integer;
  bytes       : integer;
  total_bytes : real;
  left4       : boolean;
  left1       : boolean;
  left256     : boolean;
  capture     : file;
  filename    : string[14];
  found       : boolean;

procedure purge;

  begin
    repeat
    until cgetc(1) = -1;
  end;

function upper(tstr : wstr) : wstr;

  var
    i : integer;

  begin
    for i := 1 to length(tstr) do
      tstr[i] := upcase(tstr[i]);
  end;

procedure stat_write(tstr : wstr);

  var
    x,y : integer;

  begin
    x := wherex;
    y := wherey;
    textcolor(0);
    textbackground(7);
    window(1,1,80,25);
    gotoxy(1,25);
    clreol;
    write(output,tstr);
    gotoxy(65,25);
    write('Terminal 1.0');
    window(1,1,80,24);
    textcolor(7);
    textbackground(0);
    gotoxy(x,y);
  end;

function stat_read(pstr : wstr) : wstr;

  var
    x,y  : integer;
    tstr : wstr;

  begin
    x := wherex;
    y := wherey;
    textcolor(0);
    textbackground(7);
    window(1,1,80,25);
    gotoxy(1,25);
    clreol;
    write(output,pstr);
    gotoxy(65,25);
    write('Terminal 1.0');
    gotoxy(length(pstr) + 1,25);
    read(tstr);
    stat_read := tstr;
    window(1,1,80,24);
    textcolor(7);
    textbackground(0);
    gotoxy(x,y);
  end;

procedure dial;

  var
    parms,number,tstr : wstr;
    phonefile         : text;

    begin
      parms := stat_read('Number to dial? ');
      number := parms;
      stat_write('Dialing ' + number + '....');
      strsend('ATDT' + number + ^M);
      purge;
      repeat
      until
      cgetc(0) <> -1;
      purge;
      if old_carrier
        then
          stat_write('Dialing ' + number + '....Connected')
        else
          stat_write('Dialing ' + number + '....No Carrier');
    end;

procedure identify;

  begin
    stat_write('Sending Identification...');
    strsend('#IBM PC PCDOS,CC,PA'+^m);
    stat_write('Connected');
  end;

procedure protocol;

  const
    ESCAPE = $1B;
    SI     = $0F;
    SO     = $0E;
    SOH    = $01;
    ETX    = $03;
    EOT    = $04;
    ENQ    = $05;
    DLE    = $10;
    A_EOF  = $1A;
    A_ACK  = '.';
    A_NAK  = '/';
    A_ABORT  = $11;

  var
    count : integer;
    recvd : integer;
    done  : boolean;

  procedure filetrana;

    var
      recnum   : integer;
      tstr     : wstr;
      size     : wstr;
      checksum : integer;
      areclen  : integer;
      arecord  : buftype;
      status   : integer;
      i        : integer;

    function increc(c : integer) : integer;

      begin
        if c = ord('9')
          then
            increc := ord('0')
          else
            increc := c + 1;
      end;

    function getarecord(var arecord : buftype) : integer;

      var
        retries : integer;
        recvd   : integer;
        gotchk  : integer;
        buffptr : integer;
        line    : bigstring;
        return  : integer;
        stat    : integer;

      function getmask : integer;

        var
          ch : integer;

        begin
          repeat
            ch := cgetc(0);
          until ch > 0;
          if ch = DLE
            then
              ch := (cgetc(30) and $1F) or 256;
          getmask := ch;
        end;

      function getcheck : integer;

        var
          ch : integer;
          c  : integer;

        begin
          ch := getmask;
          if ch <> ETX
            then
              begin
                c := ch and $FF;
                if (checksum and $80) = 0
                  then
                    checksum := checksum shl 1
                  else
                    checksum := ((checksum shl 1) and $FF) + 1;
                checksum := checksum + c;
                if checksum >= $100
                  then
                    checksum := (checksum + 1) and $FF;
              end;
          getcheck := ch;
        end;

      begin
        return := 1;
        retries := 1;
        while (retries < 10) and (return = 1) do
          begin
            retries := retries + 1;
            repeat
              stat := cgetc(30);
            until (stat = -1) or (stat = SOH) or ((stat and $7f) = SOH);
            stat := stat and $7f;
            if SOH = stat
              then
                begin
                  checksum := 0;
                  recvd := getcheck and $7F;
                  if increc(recvd) = recnum
                    then
                      begin
                        stat_write('Invalid record number (off by 1)');
                        purge;
                        send(ord(A_ACK));
                      end
                    else
                      if recvd <> recnum
                        then
                          begin
                            stat_write('Invalid record number: ' + chr(recvd + 48));
                            purge;
                            send(ord(A_NAK));
                          end
                        else
                          begin
                            areclen := 0;
                            buffptr := 0;
                            recvd := getcheck;
                            while ETX <> recvd do
                              begin
                                arecord[buffptr] := chr(recvd);
                                buffptr := succ(buffptr);
                                areclen := succ(areclen);
                                if (areclen mod 16) = 0
                                  then
                                    begin
                                      tstr := tstr + '.';
                                      stat_write(tstr);
                                    end;
                                recvd := getcheck;
                              end;

                            gotchk := getmask and $FF;
                            if checksum = gotchk
                              then
                                begin
                                  tstr := '';
                                  recnum := increc(recnum);
                                  return := 0;
                                end
                              else
                                begin
                                  stat_write(' NAK');
                                  tstr := copy(tstr,1,12);
                                  stat_write(tstr);
                                  purge;
                                  send(ord(A_NAK));
                                end;
                          end;
                end;
          end;
        if return = 1
          then
            begin
              stat_write('Too many retries');
              send(ord(^U));
              getarecord := 1;
            end
          else
            getarecord := 0;
      end;

    procedure a_download(var arecord : buftype);

      var
        filename : string[30];
        dowfile  : file of byte;
        i,ch     : integer;
        end_file : byte;
        tint     : integer;
        rply     : char;
        abort    : boolean;
        done     : boolean;
        f_eof    : boolean;
        outbyte  : byte;

      begin
        stat_write('File download requested');
        abort := false;
        done  := false;
        i := 2;
        filename := '';
        while arecord[i] <> ^M do
          begin
            filename := filename + arecord[i];
            i := succ(i);
          end;
      {$i-} {turn of io checking}
        assign(dowfile,filename);
        reset(dowfile);
        if ioresult = 0
          then
            begin
              close(dowfile);
              stat_write('The file, "' + filename +
                         '", already exists.  Overwrite it? (y/n)');
              read(kbd,rply);
              abort := not(rply in ['Y','y']);
            end;

        if not abort
          then
            begin
              rewrite(dowfile);
              abort := ioresult <> 0;
              if abort
                then
                  stat_write('Unable to open/create, "' + filename + '"');
            end;

        if not abort
          then
            begin
              tstr := 'Receiving file: ' + filename + ' as ';
              if arecord[1] = 'B'
                then
                  begin
                    end_file := 4;
                    stat_write(tstr + 'a binary file.');
                  end
                else
                  begin
                    end_file := 26;
                    stat_write(tstr + 'as an ascii file.');
                  end;
              while not done do
                begin
                  str(longfilesize(dowfile): 6: 0,size);
                  tstr := chr(recnum) + ' (' + size + '):  ';
                  stat_write(tstr);
                  purge;
                  send(ord(A_ACK));
                  if getarecord(arecord) <> 0
                    then
                      begin
                        stat_write('Communications failure!');
                        close(dowfile);
                        done := true;
                      end
                    else
                      begin
                        i := 0;
                        f_eof := i >= areclen;
                        while not f_eof do
                          if ((arecord[i] = chr(EOT)) and (areclen = 1)) or
                             ((arecord[i] = chr(A_EOF)) and (end_file = A_EOF))
                            then
                              begin
                                f_eof := true;
                                close(dowfile);
                                stat_write('download complete.');
                                purge;
                                send(ord(A_ACK));
                              end
                            else
                              begin
                                outbyte := byte(arecord[i]);
                                write(dowfile,outbyte);
                                flush(dowfile);
                                i := succ(i);
                                f_eof := i >= areclen;
                              end;
                        if i < areclen
                          then
                            done := true;
                      end;
                end;
            end;
      end;

  procedure a_upload;

    var
      filename : string[30];
      upfile   : file of byte;
      i        : integer;
      ch       : byte;
      end_hit,
      abort,
      done     : boolean;

    function sendrecord : integer;

      var
        retries : integer;
        acknak  : integer;
        quit    : boolean;

      procedure putrecord;

        var
          i : integer;
          checksum : integer;

        procedure putmasked(ch : integer);

            begin
              if not((areclen = 1) and (ch = eot))
                then
                  if ch in [$1..$4,$10,$15]
                    then
                      begin
                        send(DLE);
                        send(ch + $40);
                      end
                    else
                      send(ch and $ff)
                else
                  send(ch and $ff);
            end;

        procedure putcheck(ch : integer);

          var
            c : integer;

            begin
              c := ch and $ff;
              if (checksum and $80) = 0
                then
                  checksum := checksum shl 1
                else
                  checksum := ((checksum shl 1) and $ff) + 1;
              checksum := checksum + c;
              if checksum >= $100
                then
                  checksum := $ff and (checksum + 1);
              putmasked(ch);
            end;

          begin
            send(SOH);
            checksum := 0;
            putcheck(recnum);
            for i := 0 to areclen - 1 do
              begin
                putcheck(ord(arecord[i]));
                if (i mod 32) = 0
                  then
                    begin
                      tstr := tstr + '.';
                      stat_write(tstr);
                    end;
              end;
            send(ETX);
            putmasked(checksum);
          end;

        begin
          retries := 0;
          quit    := false;
          while (retries < 10) and not(quit) do
            begin
              retries := succ(retries);
              tstr := tstr + chr(recnum);
              stat_write(tstr);
              putrecord;
              acknak := cgetc(10);
              if acknak = ord(A_ACK)
                then
                  begin
                    recnum := increc(recnum);
                    quit := true;
                    sendrecord := 0;
                  end
                else if acknak = A_ABORT
                       then
                         begin
                           stat_write('Abort!');
                           sendrecord := 1;
                           quit := true;
                         end
                       else if acknak = ord(A_NAK)
                              then
                                begin
                                  stat_write('NAK: ' + chr(acknak));
                                  tstr := copy(tstr,1,14);
                                  stat_write(tstr);
                                  quit := false;
                                end;
            end;

          if acknak = ord(A_NAK)
            then
              begin
                send(A_ABORT);
                stat_write('Too many retries!');
                sendrecord := 1;
              end;
        end;

      begin
        tstr := 'Preparing to upload "';
        i := 2;
        filename := '';
        while arecord[i] <> ^M do
          begin
            filename := filename + arecord[i];
            i := succ(i);
          end;
        stat_write(tstr + filename + '".');
      {$i-} {turn of io checking}
        assign(upfile,filename);
        reset(upfile);
        if ioresult = 0
          then
            begin
              str(longfilesize(upfile): 0: 0,tstr);
              stat_write('"' + filename + '" is ' + tstr + ' bytes long.');
              send(ord(A_ACK));
              repeat
              until ord(A_ACK) = cgetc(10);
              repeat
                tstr := '';
                areclen := 0;
                str(longfilepos(upfile)/longfilesize(upfile)*100: 5: 1,size);
                tstr := size + '% (';
                str(longfilepos(upfile): 7: 0,size);
                tstr := tstr + size + ') -- ';
                stat_write(tstr);
                repeat
                  read(upfile,ch);
                  arecord[areclen] := chr(ch);
                  areclen := areclen + 1;
                until eof(upfile) or (areclen > 256);

                if sendrecord <> 0
                  then
                    begin
                      abort := true;
                      close(upfile);
                      stat_write('Communications failure !');
                    end
                  else
                    abort := false;
              until abort or eof(upfile);

              if not abort
                then
                  begin
                    tstr := '';
                    arecord[0] := chr(EOT);
                    areclen := 1;
                    str(longfilepos(upfile)/longfilesize(upfile)*100: 5: 1,size);
                    tstr := size + '% (';
                    str(longfilepos(upfile): 7: 0,size);
                    tstr := tstr + size + ') -- ';
                    stat_write(tstr);
                    ch := sendrecord;
                    close(upfile);
                  end;
            end
          else
            begin
              stat_write('Cannot open "' + filename + '".');
              send(A_ABORT);
            end;
      end;

    begin
      stat_write('File transfer requested');
      recnum := ord('1');
      repeat
        status := getarecord(arecord);
      until (status = 0) or keypressed;
      if status = 0
        then
          case arecord[0] of
            'U' : a_upload;
            'D' : a_download(arecord);
          end;
    end;


  begin
    done := false;
    repeat
      recvd := cgetc(10);
      if recvd > 0
        then
          begin
            recvd := recvd and $7F;
            while (recvd = SI) or (recvd = -1) do
              recvd := cgetc(1);
            if recvd <> SO
              then
                begin
                  if recvd = ESCAPE
                    then
                      repeat
                        recvd := cgetc(0) and $7F;
                        case char(recvd) of
                          'I' : identify;
                          'A' : filetrana;
                          'G' : {graphics;}
                        end;
                      until recvd in [65,71,73,SO]
                    else
                      done := true;
                  recvd := cgetc(1);
                end
          end
        else
          done := true;
      done := done or keypressed or (recvd = SO);
    until done;
    stat_write('Connected');
  end;

procedure escape;

  var
    rcvd : integer;
    ch   : char;
    x,y  : integer;

  begin
    rcvd := cgetc(1);
    if rcvd > 0
      then
        case rcvd of
          89 : begin
                 y := cgetc(1) - 31;
                 x := cgetc(1) - 31;
                 gotoxy(x,y);
               end;
          65 : gotoxy(wherex,wherey - 1);
          66 : gotoxy(wherex,wherey + 1);
          67 : gotoxy(wherex + 1,wherey);
          68 : gotoxy(wherex - 1,wherey);
          71 : {graphics};
          72 : gotoxy(1,1);
          73 : identify;
          75 : clreol;
          74 : begin
                 clreol;
                 for y := wherey + 1 to 25 do
                   begin
                     gotoxy(1,y);
                     clreol;
                   end;
               end;
          106 : clrscr;
        end;
  end;

{$u-}
begin {terminal}
  stat_write('Initializing');
  buffptr := minint;
  save := false;
  left1 := false;
  left4 := false;
  left256 := false;
  new(buffer);
  set_up_recv_buffer;
  setup;
  exit   := false;
  stat_write('Ready');
  old_carrier := false;

  repeat
    if old_carrier xor carrier
      then
        begin
          old_carrier := carrier;
          if old_carrier
            then
              stat_write('Connected')
            else
              stat_write('No Carrier');
        end;

    if keypressed
      then
        begin
          read(kbd,ch);
          if ch = ^[
            then
              begin
                read(kbd,ch);
                case ord(ch) of
                  32 : dial;
                  25 : begin
                         parms := stat_read('Set parameter (parameter,value) ?');
                         i := 1;
                         while i <= length(parms) do
                           begin
                             case parms[i] of
                               'f','F' : begin
                                           filename := copy(parms,pos(',',parms) + 1,
                                                       length(parms) - pos(',',parms));
                                           i := length(parms) + 1;
                                         end;
                               'b','B' : begin
                                           i := length(parms) + 1;
                                           tstr := copy(parms,pos(',',parms) + 1,
                                                   length(parms) - pos(',',parms));
                                           parms := '';
                                           for i := 1 to length(tstr) do
                                             if tstr[i] in ['0'..'9']
                                               then
                                                 parms := parms + tstr[i];
                                           val(parms,j,i);
                                           if i = 0
                                             then
                                               speed := j;
                                           stat_write('New Baud Rate: ' + parms);
                                           init_port;
                                           delay(2000)
                                         end;
                               'p','P' : begin
                                           i := length(parms) + 1;
                                           tstr := copy(parms,pos(',',parms) + 1,
                                                   length(parms) - pos(',',parms));
                                           j := 1;
                                           while j <= length(tstr) do
                                             case tstr[j] of
                                               'e','E' : begin
                                                           parity := even;
                                                           j := length(tstr) + 1
                                                         end;
                                               'n','N' : begin
                                                           parity := none;
                                                           j := length(tstr) + 1;
                                                         end
                                               else
                                                 j := j + 1;
                                             end;
                                           stat_write('New parity: '+ tstr);
                                           init_port;
                                           delay(2000);
                                         end;
                               's','S' : begin
                                           tstr := copy(parms,pos(',',parms) + 1,
                                                   length(parms) - pos(',',parms));
                                           parms := '';
                                           for i := 1 to length(tstr) do
                                             if tstr[i] in ['1','2']
                                               then
                                                 parms := tstr[i];
                                           val(parms,j,i);
                                           if i = 0
                                             then
                                               stop_bits := j;
                                           stat_write('New Stop Bits: ' + parms);
                                           init_port;
                                           delay(2000)
                                         end;

                               'w','W' : begin
                                           tstr := copy(parms,pos(',',parms) + 1,
                                                   length(parms) - pos(',',parms));
                                           parms := '';
                                           for i := 1 to length(tstr) do
                                             if tstr[i] in ['7','8']
                                               then
                                                 parms := tstr[i];
                                           val(parms,j,i);
                                           if i = 0
                                             then
                                               dbits := j;
                                           stat_write('New Data Bits: ' + parms);
                                           init_port;
                                           delay(2000)
                                         end;

                               'd','D' : begin
                                           tstr := 'Current: ';
                                           str(speed,parms);
                                           tstr := tstr + parms + ' baud, ';
                                           str(dbits,parms);
                                           tstr := tstr + parms + ' data bits, ';
                                           str(stop_bits,parms);
                                           tstr := tstr + parms + ' stop bits, ';
                                           if parity = none
                                             then
                                               tstr := tstr + 'no parity';
                                           if parity = even
                                             then
                                               tstr := tstr + 'even parity';
                                           stat_write(tstr);
                                           delay(2000);
                                         end;

                             else
                               i := i + 1;
                           end;
                       end;
                  if old_carrier
                    then
                      stat_write('Connected')
                    else
                      stat_write('No Carrier');
                end;
                31 : begin
                       save := true;
                       stat_write('Capture buffer on');
                       delay(100);
                       if old_carrier
                         then
                           stat_write('Connected')
                         else
                           stat_write('No Carrier');
                     end;
                46 : begin
                       save := false;
                       stat_write('Capture buffer off');
                       delay(100);
                       if old_carrier
                         then
                           stat_write('Connected')
                         else
                           stat_write('No Carrier');
                     end;
                17 : begin
                       stat_write('Saving capture buffer to "' + filename + '"');
                       assign(capture,filename);
               {$i-}
                       reset(capture);
                       if ioresult = 0
                         then
                           longseek(capture,longfilesize(capture))
                         else
                           rewrite(capture);
                       blockwrite(capture,buffer^,((buffptr + 32767) div 128) + 2);
                       str((((buffptr + 32767) div 128) + 1): 5,tstr);
                       stat_write(tstr);
                       delay(2000);
                       close(capture);
                       buffptr := minint;
                       if old_carrier
                         then
                           stat_write('Connected')
                         else
                           stat_write('No Carrier');
                     end;
                37 : begin
                       stat_write('Clearing capture buffer');
                       delay(100);
                       buffptr := minint;
                       left4 := false;
                       left1 := false;
                       left256 := false;
                       if old_carrier
                         then
                           stat_write('Connected')
                         else
                           stat_write('No Carrier');
                     end;
                45 : begin
                       exit := true;
                       stat_write('Exiting...');
                     end;
                35 : begin
                       term_ready(false);
                       delay(10);
                       stat_write('Disconnecting...');
                       term_ready(true);
                     end;
              end;
        end
      else
        send(ord(ch));
      end;

    if not exit
      then
        begin

          rcvd := cgetc(0);

          if save and (rcvd > 0)
            then
              begin
                if (buffptr > (maxint - 4096)) and not left4
                  then
                    begin
                      left4 := true;
                      stat_write('Only 4k left in capture buffer');
                    end;
                if (buffptr > (maxint - 1024)) and not left1
                  then
                    begin
                      left1 := true;
                      stat_write('Only 1k left in capture buffer');
                    end;
                if (buffptr > (maxint - 256)) and not left256
                  then
                    begin
                      left256 := true;
                      stat_write('Only 256 bytes left in capture buffer');
                    end;
                if buffptr = maxint
                  then
                    begin
                      stat_write('Capture buffer closed.');
                      save := false;
                    end
                  else
                    begin
                      buffer^[buffptr] := rcvd and $7f;
                      buffptr := succ(buffptr);
                    end;
              end;

          if rcvd > 0
            then
              case rcvd of
                15      : protocol;
                14      : ;
                12      : clrscr;
                13      : write(^M);
                10      : write(^J);
                8      : write(^h,' ',^h);
                27      : escape;
                32..255 : write(chr(rcvd and $7F));
              end;
        end;

  until exit;
  dispose(buffer);
  remove_port;
  textbackground(0);
  textcolor(7);
end.