Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FORUM25C.ZIP/PROTOCOL.PAS

Pascal/Delphi Source File | 1988-12-27 | 18.1 KB | 738 lines

{$R-,S-,I-,D-,V-,B-,N-,L- }
{$O+}

{ $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.