Jason Aller Floppy Collection/276.img/FORUM21S.ZIP/PROTOCOL.PAS

Pascal/Delphi Source File | 1988-02-13 | 17.8 KB | 729 lines

{$R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }
{$M 65500,0,0 }

{ $define testprotocol}  (* Close this define for test mode *)

{$ifdef testprotocol}
{*}
{*}uses crt,dos,
{*}     modem;
{*}
{*}{$I-}
{*}type anystr=string[255];
{*}     lstr=string[80];
{*}     mstr=string[30];
{*}     sstr=string[15];
{*}var logontime,iocode:integer;
{*}const timer=0; timeleft=1; numminsxfer=1;
{*}function keyhit:boolean;
{*}begin
{*}  keyhit:=keypressed
{*}end;
{*}function bioskey:char;
{*}var k:char;
{*}begin
{*}  read (kbd,k);
{*}  bioskey:=k
{*}end;
{*}function hungupon:boolean;
{*}begin
{*}  hungupon:=not carrier
{*}end;
{*}function strr (n:integer):mstr;
{*}var q:mstr;
{*}begin
{*}  str (n,q);
{*}  strr:=q
{*}end;
{*}function minstr (blocks:integer):mstr;
{*}begin
{*}  minstr:='<'+strr(blocks)+' blocks left>'
{*}end;
{*}procedure fileerror (s1,s2:lstr);
{*}begin
{*}  writeln ('File error ',s1,' and ',s2);
{*}  halt
{*}end;
{*}procedure starttimer (q:integer); begin end;
{*}procedure stoptimer (q:integer); begin end;
{*}procedure settimeleft (q:integer); begin end;
{*}procedure splitscreen (y:integer);
{*}begin
{*}  window (1,1,80,y-1)
{*}end;
{*}procedure top; begin end;
{*}procedure unsplit;
{*}begin
{*}  window (1,1,80,25)
{*}end;
{*}
{*}
{*}
{*}function protocolxfer (send,crcmode,ymodem:boolean; fn:lstr):integer;

{$else}

unit protocol;

interface

uses dos,crt,
     gentypes,modem,statret,windows,gensubs,subs1,subs2;

function protocolxfer (send,crcmode,ymodem:boolean; fn:lstr):integer;
{ Return codes:  0=OK, 1=Cancelled within last three blocks, 2=Aborted }

implementation

function protocolxfer (send,crcmode,ymodem:boolean; fn:lstr):integer;

{$endif}

  const can=^X; ack=^F; nak=^U; soh=^A; stx=^B; eot=^D; crcstart='C';

  var timedout:boolean;

  function tenthseconds:integer;
  var r:registers;
  begin
    r.ah:=$2c;
    intr ($21,r);
    tenthseconds:=(r.dh*10)+(r.dl div 10)
  end;

  function fromnow (tenths:integer):integer;
  begin
    tenths:=tenthseconds+tenths;
    if tenths>599 then tenths:=tenths-600;
    fromnow:=tenths
  end;

  function timeout (en:integer):boolean;
  begin
    timeout:=(en=tenthseconds) or hungupon
  end;

  procedure clearmodemahead;
  var k:char;
  begin
    while numchars>0 do k:=getchar
  end;

  procedure wait (tenths:integer);
  begin
    tenths:=fromnow (tenths);
    repeat until timeout (tenths) or hungupon
  end;

  function waitchar (tenths:integer):char;
  begin
    waitchar:=#0;
    tenths:=fromnow (tenths);
    repeat
      if numchars>0 then begin
        waitchar:=getchar;
        timedout:=false;
        exit
      end
    until timeout (tenths) or hungupon;
    timedout:=true
  end;

  procedure computecrc (var block; blocksize:integer; var outcrc:word);
  var cnt,c2:integer;
      crc,b:word;
      blk:array[1..1030] of byte absolute block;
      willbecarry:boolean;
  begin
    crc:=0;
    for cnt:=1 to blocksize do begin
      b:=blk[cnt];
      for c2:=1 to 8 do begin
        willbecarry:=(crc and $8000)=$8000;
        crc:=(crc shl 1) or (b shr 7);
        b:=(b shl 1) and 255;
        if willbecarry then crc:=crc xor $1021
      end
    end;
    outcrc:=crc
  end;

(****
    inline (
             $1E/                    {           PUSH  DS               }
             $C5/$B6/block/          {           LDS   SI,[BP+block]    }
             $8B/$96/blocksize/      {           MOV   DX,[BP+blocksize]}
             $31/$DB/                {           XOR   BX,BX            }
             $FC/                    {           CLD                    }
             $AC/                    { Mainloop: LODSB                  }
             $B9/$08/$00/            {           MOV   CX,0008          }
             $D0/$E0/                { Byteloop: SHL   AL,1             }
             $D1/$D3/                {           RCL   BX,1             }
             $73/$04/                {           JNC   No_xor           }
             $81/$F3/$21/$10/        {           XOR   BX,1021          }
             $E2/$F4/                { No_xor:   LOOP  Byteloop         }
             $4A/                    {           DEC   DX               }
             $75/$ED/                {           JNZ   Mainloop         }
             $89/$9E/crc/            {           MOV   [BP+crc],BX      }
             $1F                     {           POP   DS               }
           );
****)

  procedure computecksum (var data; blocksize:integer; var outcksum:byte);
  var t:array [1..1024] of byte absolute data;
      cnt,q:integer;
  begin
    q:=0;
    for cnt:=1 to blocksize do q:=q+t[cnt];
    outcksum:=q and 255
  end;

  procedure showerrorstats (curblk,totalerrs,consec:integer);
  var x:integer;
      r:real;
  begin
    x:=wherex;
    write (usr,totalerrs);
    gotoxy (x,wherey+1);
    write (usr,consec,' ');
    gotoxy (x,wherey+1);
    if curblk+totalerrs<>0 then begin
      r:=round(10000.0*totalerrs/(curblk+totalerrs))/100.0;
      write (usr,r:0:2,'%    ')
    end
  end;

  {overlay} function xymodemsend (ymodem:boolean):integer;
  var f:file;
      b:array [1..1026] of byte;
      blocksize:integer;
      fsize,curblk,totalerrs,consec,blocksatatime:integer;
      k:char;
      firstblock:boolean;
      totaltime:sstr;

    function getctrlchar:char;   { Gets ACK/NAK/CAN }
    var k,k2:char;
        cnt:integer;
    begin
      getctrlchar:=can;
      repeat
        cnt:=0;
        repeat
          k:=waitchar (10);
          cnt:=cnt+1;
          if keyhit then begin
            k2:=bioskey;
            if k2=^X then exit;
            timedout:=true
          end
        until (not timedout) or (cnt=60);
        if timedout or hungupon then exit;
        if (k in [ack,nak,crcstart,can]) then begin
          getctrlchar:=k;
          if k=can then sendchar (can);
          exit
        end
      until hungupon;
      timedout:=true
    end;

    procedure sendendoffile;
    var k:char;
        tries:integer;
    begin
      tries:=0;
      repeat
        tries:=tries+1;
        sendchar(eot);
        k:=waitchar (20);
      until (k=ack) or (k=can) or (tries=3);
      sendchar(eot)
    end;

    procedure getblockfromfile;
    begin
      fillchar (b,sizeof(b),26);
      blockread (f,b,blocksatatime);
      blocksize:=blocksatatime shl 7
    end;

    procedure buildfirstblock;
    var cnt,p:integer;
    begin
      blocksize:=128;
      fillchar(b,128,0);
      p:=length(fn);
      repeat
        p:=p-1
      until (p=0) or (fn[p]='\');
      for cnt:=1 to length(fn)-p do b[cnt]:=ord(fn[cnt+p])
    end;

    procedure sendblock (num:integer);
    var cnt,bksize:integer;
        crc:word;
        n:byte;
        k:char;
    begin
      clearmodemahead;
      n:=num and 255;
      if blocksize=1024
        then k:=stx
        else k:=soh;
      if crcmode
        then
          begin
            b[blocksize+1]:=0;
            b[blocksize+2]:=0;
            computecrc (b,blocksize+2,crc);
            b[blocksize+1]:=hi(crc);
            b[blocksize+2]:=lo(crc);
            bksize:=blocksize+2;
          end
        else
          begin
            b[blocksize+1]:=0;
            computecksum (b,blocksize,b[blocksize+1]);
            bksize:=blocksize+1
          end;
      sendchar (k);
      sendchar (chr(n));
      sendchar (chr(255-n));
      for cnt:=1 to bksize do sendchar(chr(b[cnt]))
    end;

    procedure updatestatus;
    begin
      gotoxy (16,3);
      write (usr,curblk,' of ',fsize);
      gotoxy (16,4);
      write (usr,minstr((fsize-curblk)*blocksatatime),' of ',totaltime,' ');
      gotoxy (16,5);
      showerrorstats (curblk,totalerrs,consec)
    end;

    procedure initxfer;
    begin
      starttimer (numminsxfer);
      if ymodem then blocksatatime:=8 else blocksatatime:=1;
      fsize:=(filesize(f)+blocksatatime-1) div blocksatatime;
      totaltime:=minstr(fsize*blocksatatime);
      totalerrs:=0;
      consec:=0;
      firstblock:=true;
      if ymodem
        then
          begin
            curblk:=0;
            buildfirstblock
          end
        else
          begin
            curblk:=1;
            getblockfromfile
          end;
      splitscreen (8);
      top;
      write (usr,'Waiting for NAK')
    end;

    procedure setupscreen;
    begin
      gotoxy (1,1);
      if ymodem then write (usr,'Y') else write (usr,'X');
      write (usr,'MODEM');
      if crcmode then write (usr,'-CRC');
      writeln (usr,' send in progress.  Press Ctrl-X to abort.');
      clreol;
      gotoxy (1,3);
      writeln (usr,'Current block:');
      writeln (usr,'Time left:');
      writeln (usr,'Total errors:');
      writeln (usr,'  Consecutive:');
      write (usr,'Error rate:')
    end;

  label abort,done;
  begin
    xymodemsend:=2;
    assign (f,fn);
    reset (f);
    iocode:=ioresult;
    if iocode<>0 then exit;
    initxfer;
    repeat
      k:=getctrlchar;
      if k=can then begin
        if (curblk>(fsize*3/4)) and (curblk>2)
          then xymodemsend:=1; { Cheater! }
        goto abort
      end;
      if firstblock then begin
        if (k=nak) or (k=crcstart) then firstblock:=false;
        crcmode:=k=crcstart;
        setupscreen;
        k:=#0
      end;
      if k=ack then begin
        curblk:=curblk+1;
        if eof(f) then goto done;
        getblockfromfile
      end;
      if k<>nak then consec:=0 else begin
        totalerrs:=totalerrs+1;
        consec:=consec+1
      end;
      sendblock(curblk);
      updatestatus
    until 0=1;
    done:
    sendendoffile;
    xymodemsend:=0;
    abort:
    close (f);
    unsplit;
    stoptimer (numminsxfer)
  end;

  {overlay} function xymodemreceive(ymodem:boolean):integer;
  var f:file;
      block:array [1..1026] of byte;
      blkl,blkh,xblkl,nblkl,nblk1:byte;
      curblk:integer;
      ctrl,k,k2:char;
      timeul,consec,totalerrs,blocksize:integer;
      canceled,timeout:boolean;

    procedure cancel;
    begin
      wait (10);
      clearmodemahead;
      sendchar (can);
      wait (10);
      clearmodemahead;
      sendchar (can);
      canceled:=true
    end;

    function writeblock:boolean;
    var wb:boolean;
    begin
      blockwrite (f,block,blocksize div 128);
      wb:=ioresult=0;
      writeblock:=wb;
      if not wb then begin
        gotoxy (1,1);
        write (usr,'I/O ERROR ',iocode,' WRITING BLOCK');
        clreol;
        sendchar (can);
        wait (10);
        sendchar (can);
        clearmodemahead
      end
    end;

    procedure updatestatus;
    begin
      curblk:=blkl+(blkh shl 8);
      gotoxy (16,3);
      write (usr,curblk);
      gotoxy (16,4);
      showerrorstats (curblk,totalerrs,consec)
    end;

    function sendctrl:char;
    var cnt,consec:integer;
        k:char;
    begin
      cnt:=0;
      consec:=0;
      timeout:=false;
      updatestatus;
      sendctrl:=can;
      repeat
        if keyhit then begin
          k:=bioskey;
          if k=^X then begin
            timeout:=true;
            cancel;
            exit
          end
        end;
        sendctrl:=waitchar (50);
        if not timedout then exit;
        sendchar (ctrl);
        cnt:=0;
        consec:=consec+1
      until (consec=10) or hungupon;
      timeout:=true
    end;

    function getachar:char;
    var cnt:integer;
        k:char;
    begin
      getachar:=#0;
      timeout:=timeout or hungupon;
      if timeout then exit;
      timeout:=false;
      if keyhit then begin
        k:=bioskey;
        if k=^X then begin
          getachar:=#0;
          timeout:=true;
          cancel;
          exit
        end
      end;
      getachar:=waitchar (10);
      timeout:=timeout or timedout
    end;

    procedure xfererror (txt:lstr);
    begin
      gotoxy (16,7);
      write (usr,txt,' in block ',curblk);
      clreol
    end;

    procedure initxfer;
    var k:char;
    begin
      timeul:=timer;
      timeout:=false;
      consec:=0;
      blkl:=1;
      blkh:=0;
      xblkl:=1;
      curblk:=1;
      totalerrs:=0;
      if crcmode
        then ctrl:=crcstart
        else ctrl:=nak;
      canceled:=false;
      starttimer (numminsxfer);
      splitscreen (8);
      top;
      gotoxy (1,1);
      if ymodem then write (usr,'Y') else write (usr,'X');
      write (usr,'MODEM');
      if crcmode then write (usr,'-CRC');
      write (usr,' receive in progress.  Press Ctrl-X to abort.'^M^J^J,
             'Current block:'^M^J,
             'Total errors:'^M^J,
             '  Consecutive:'^M^J,
             'Error rate:'^M^J,
             'Error type:');
      while numchars>0 do k:=getchar
    end;

    procedure endoffile;
    begin
      xymodemreceive:=0;
      sendchar (ack);
      wait (10);
      sendchar (ack);
      clearmodemahead
    end;

    function block0:boolean;
    var b0:boolean;
        cnt:integer;
    begin
      b0:=(nblkl=0) and (nblk1=255) and (blkh=0) and (blkl<>255);
      if b0 then begin
        xfererror ('(Receiving block 0...)');
        for cnt:=1 to blocksize do block[cnt]:=ord(getachar);
        ctrl:=ack;
        sendchar (ack)
      end;
      block0:=b0
    end;

    function blocknumerror:boolean;
    var bne:boolean;
    begin
      bne:=(nblkl<>(255-nblk1)) or ((nblkl<>xblkl) and (nblkl<>blkl));
      if bne then xfererror ('Block # '+strr(nblkl)+' not '+strr(255-nblk1)+
                             ' and '+strr(xblkl)+' or '+strr(blkl));
      blocknumerror:=bne
    end;

    function resentnoreason:boolean;
    var rnr:boolean;
        cnt:integer;
    begin
      rnr:=(nblkl<>xblkl) and (nblkl=blkl);
      if rnr then begin
        xfererror ('Block re-sent for no reason');
        for cnt:=1 to blocksize do block[cnt]:=ord(getachar);
        ctrl:=ack;
        sendchar (ack)
      end;
      resentnoreason:=rnr
    end;

    procedure getblockfrommodem;
    var cnt:integer;
    begin
      for cnt:=1 to blocksize do begin
        block[cnt]:=ord(getachar);
        if timeout then exit
      end
    end;

    function badblock:boolean;
    var crc:word;
        cksum,reccksum:byte;
    begin
      badblock:=false;
      if crcmode
        then
          begin
            computecrc(block,blocksize,crc);
            if crc<>0 then begin
              xfererror ('CRC error');
              badblock:=true
            end
          end
        else
          begin
            reccksum:=block[129];
            block[129]:=0;
            computecksum(block,blocksize,cksum);
            if cksum<>reccksum then begin
              xfererror ('Checksum error');
              badblock:=true
            end
          end
    end;

  label nakit,abort,done;
  begin
    xymodemreceive:=2;
    assign (f,fn);
    rewrite (f);
    iocode:=ioresult;
    if iocode<>0 then begin
      fileerror ('XYMODEMRECEIVE',fn);
      exit
    end;
    initxfer;
    repeat
      k:=sendctrl;
      ctrl:=nak;
      if timeout or (k=can) then goto abort;
      if k=eot then begin
        endoffile;
        goto done
      end;
      case k of
        soh:blocksize:=128;
        stx:blocksize:=1024
        else begin
          xfererror ('SOH error: '+strr(ord(k)));
          goto nakit
        end
      end;
      if crcmode
        then blocksize:=blocksize+2
        else blocksize:=blocksize+1;
      nblkl:=ord(getachar);
      nblk1:=ord(getachar);
      if timeout then goto nakit;
      if block0 then goto nakit;
      if blocknumerror then goto nakit;
      if resentnoreason then goto nakit;
      if (nblkl=0) and (blkl=255) then blkh:=blkh+1;
      blkl:=nblkl;
      getblockfrommodem;
      if timeout then goto nakit;
      if badblock then goto nakit;
      ctrl:=ack;
      xblkl:=blkl+1;
      sendchar (ack);
      updatestatus;
      if not writeblock then goto abort;
      consec:=0;
      nakit:
      if hungupon then goto abort;
      if timeout then xfererror ('Time out (short block)');
      if ctrl<>ack then begin
        totalerrs:=totalerrs+1;
        consec:=consec+1;
        repeat
          k:=waitchar (10)
        until timedout;
        if consec>=15 then begin
          sendchar (can);
          goto abort
        end;
        sendchar (ctrl)
      end
    until 0=1;
    abort:
    cancel;
    done:
    close (f); consec:=ioresult;
    if canceled then begin
      erase (f); consec:=ioresult
    end;
    timeul:=timer-timeul;
    if timeul<0 then timeul:=timeul+1440;
    settimeleft (timeleft+timeul*2);
    unsplit;
    stoptimer (numminsxfer)
  end;

begin
  if send
    then protocolxfer:=xymodemsend(ymodem)
    else protocolxfer:=xymodemreceive(ymodem)
end;


{$ifdef testprotocol}
{*}
{*}
{*}procedure termmode;
{*}var k:char;
{*}begin
{*}  clrscr;
{*}  writeln ('Termmode- ^D when done, or ^A to abort.');
{*}  setparam (1,1200,false);
{*}  repeat
{*}    if keyhit then begin
{*}      k:=bioskey;
{*}      if k=^A then halt else if k=^D then exit else sendchar (k)
{*}    end;
{*}    while numchars>0 do write (getchar)
{*}  until 0=1
{*}end;
{*}var k:char;
{*}    fn:lstr;
{*}    b:integer;
{*}    snd,crcm,ymd:boolean;
{*}begin
{*}  checkbreak:=false;
{*}  termmode;
{*}  write ('Filename: ');
{*}  readln (fn);
{*}  if length(fn)=0 then halt;
{*}  write ('S=Send: ');    k:=bioskey;  snd:=upcase(k)='S'; if k=^C then halt;
{*}  write ('C=Crc: ');     k:=bioskey; crcm:=upcase(k)='C'; if k=^C then halt;
{*}  write ('Y=Ymodem: ');  k:=bioskey;  ymd:=upcase(k)='Y'; if k=^C then halt;
{*}  writeln;
{*}  writeln;
{*}  clrscr;
{*}  b:=protocolxfer (snd,crcm,ymd,fn);
{*}  gotoxy (1,24);
{*}  writeln ('Returned: ',b)
{*}
{*}{$endif}

end.