Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/JBCOMM50.ZIP/MODEM7.PAS

Pascal/Delphi Source File | 1988-11-26 | 30.4 KB | 1,314 lines

unit modem7;

interface

uses jbcomm,dos;

const
     bbsname  : string = 'MULTI-BBS            ';

type filestr  = string[20];
     fileptr  = ^filetype;
     filetype = record
                                    name : filestr;
                                    nxt  : fileptr
                                end;
     xfertype = (xmodem_chk,xmodem_crc,telink,modem7_chk,
                                 modem7_crc,ymodem,ymodem_batch);


function  tmodem7(cp:porttype;path:comstr;transfer:xfertype):word;
function  rmodem7(cp:porttype;path:comstr;transfer:xfertype):word;
procedure addfile(cp:porttype;name:filestr);
function  getfile(cp:porttype):filestr;

implementation

const
  SOH          = ^A;
  STX          = ^B;
  EOT          = ^D;
    ACK          = ^F;
  BS           = ^H;
    NAK          = ^U;
  SYN          = ^V;
  CAN          = ^X;
    SUB          = ^Z;

    timeout      = -1;
    one_second   = 1000;
    two_seconds  = 2*one_second;
  five_seconds = 5*one_second;
    ten_seconds  = 10*one_second;

var head, tail : array [porttype] of fileptr;

procedure addfile(cp:porttype;name:filestr);
var newname : fileptr;
begin
    new(newname);
    if head[cp]=nil then head[cp]:=newname
    else tail[cp]^.nxt:=newname;
    newname^.name:=name; newname^.nxt:=nil;
    tail[cp]:=newname
end;

function getfile(cp:porttype):filestr;
var getname : fileptr;
begin
    if head[cp]<>nil then
    begin
        getname:=head[cp];head[cp]:=head[cp]^.nxt;
        getfile:=getname^.name;dispose(getname)
    end
    else getfile:=''
end;


function tmodem7;
type memarray    = array [0..65000] of char;
const max_read_size = 8192;

var xfile       : file;
    read_buffer : ^memarray;
    file_entry  : searchrec;
    new_header_ch,
    header_ch   : char;
    block       : array [1..2048] of char;
        long_buffer,
        EOF_xfile,
        stop_send   : boolean;
        i,
        buffer_pos,
        buffer_size,
        buffer_length,
        successful,
        recsread,
        max_tries,
        good_blocks,
        bad_blocks,
        bad_threshold,
        block_num,
        block_size,
        block_cnt,
        block_len,
        CRC,
        tries,
    errors      : word;
        inch        : integer;
        filename,
        tname       : filestr;


  procedure send_xmodem(use_crc:boolean);

  var i : word;


    procedure send_block;
    var i : word;
    begin
            crc:=0;
          tries:=0;
            repeat
                c_putc(cp,header_ch);
                c_putc(cp,chr(block_num));
                c_putc(cp,chr(255-block_num));
                for i:=1 to block_size do
                begin
                    c_putc(cp,block[i]);
                    if use_crc then
                        crc:=crc_update(crc,ord(block[i]))
                    else
                        crc:=(crc + ord(block[i])) and 255
                end;
        if use_crc then
                begin
                    c_putc(cp,chr(hi(crc)));
                    c_putc(cp,chr(lo(crc)))
                end
                else c_putc(cp,chr(lo(crc)));
                c_flush_in(cp);
                inc(tries);
            inch:=c_getb(cp,ten_seconds);
                if inch=ord(CAN) then inch:=c_getb(cp,ten_seconds);
                if inch<>ord(ACK) then
            begin
              writeln('No ACK. ');
                    inc(errors)
                end;
          until (inch=ord(ACK)) or (inch=ord(CAN)) or (tries>max_tries) or stop_send
        end;

        procedure send_telink_header;
        var i           : word;
                old_use_crc : boolean;
        begin
          max_tries:=3;
            old_use_crc:=use_crc;
            use_crc:=false;
            i:=block_size;
            block_size:=128;
            Header_ch:=SYN;
            send_block;
            use_crc:=old_use_crc;
          block_size:=i;
            max_tries:=10;
            if inch=ord(ACK) then
                writeln('Telink header accepted.')
            else
                writeln('Telink header not accepted.')
        end;

        procedure send_ymodem_header;
        var i          : word;
        begin
          max_tries:=3;
            i:=block_size;
            block_size:=128;
            header_ch:=SOH;
            send_block;
            block_size:=i;
            max_tries:=10;
            if inch=ord(ACK) then
                writeln('Ymodem header accepted.')
            else
                writeln('Ymodem header not accepted.')
        end;

        procedure cancel_transfer;
        begin
          c_flush_in(cp);
            c_putc(cp,CAN);
            c_putc(cp,CAN);
            c_putc(cp,CAN);
            c_putc(cp,CAN);
            c_putc(cp,CAN);
            c_putc(cp,BS);
            c_putc(cp,BS);
            c_putc(cp,BS);
            c_putc(cp,BS);
            c_putc(cp,BS)
        end;

    begin
      case transfer of
            xmodem_chk  : tname:='Xmodem (Checksum)';
            xmodem_CRC  : tname:='Xmodem (CRC)';
            telink      : tname:='* Telink';
            modem7_chk  : tname:='* Modem7 (Checksum)';
            modem7_CRC  : tname:='* Modem7 (CRC)';
            ymodem      : tname:='Ymodem';
            ymodem_batch: tname:='* Ymodem Batch'
        end;
        writeln('Send file '+filename+' using '+tname);
        assign(xfile,path+'\'+filename);
        reset(xfile,1);
        if ioresult<>0 then
        begin
            writeln('Cannot open file to send, transfer cancelled.');
            cancel_transfer;
            exit
        end;
        if transfer in [ymodem,ymodem_batch] then
            block_size:=1024
        else
             block_size:=128;
        max_tries:=20;
        block_num:=0;
        block_cnt:=0;
        errors:=0;
        EOF_xfile:=false;
        stop_send:=false;
        tries:=0;
        write('Waiting for NAK/C ---      '+BS+BS+BS+BS);
        c_flush_in(cp);
        repeat
            inch:=c_getb(cp,ten_seconds);
            if inch=ord(CAN) then inch:=c_getb(cp,ten_seconds);
            inc(tries);
            stop_send:=stop_send or (not c_carrier(cp))
        until (tries>max_tries) or
                    (inch=ord(NAK)) or
                    (inch=ord('C')) or
                    (inch=timeout) or
                    (inch=ord(CAN)) or
                    (inch=-2) or
                    stop_send;
        if (inch=timeout) or
             (inch=-2) or
             (tries>max_tries) or
             (inch=ord(CAN)) then
        begin
            writeln('Not Received          ');
            stop_send:=true
        end
        else if (inch=ord(NAK)) then use_crc:=false
        else if (inch=ord('C')) then use_crc:=true;
        if not stop_send then
        begin
      writeln(' Received         ');
            if transfer in [ymodem,ymodem_batch] then
                header_ch:=STX
            else
                header_ch:=SOH;
            new_header_ch:=header_ch;
            if transfer=ymodem_batch then
                send_ymodem_header
      else if transfer=telink then
                send_telink_header
        end;
        if use_crc then
            block_len:=block_size+2
        else
            block_len:=block_size+1;
        repeat
            stop_send:=stop_send or (not c_carrier(cp));
            if not stop_send then
            begin
                header_ch:=new_header_ch;
                blockread(xfile,block,block_size,recsread);
                if ioresult<>0 then
                begin
                    writeln('Cannot read data from file.');
                    stop_send:=true
                end
                else if recsread<=0 then EOF_xfile:=true
                else
                begin
                    inc(block_num);
                    inc(block_cnt);
                    send_block;
                    if inch=ord(ACK) then
                    begin
                        inc(good_blocks);
                        write('Blocks ',block_cnt:5,13)
                    end
                    else
                    begin
                        writeln('Bad Block');
            inc(bad_blocks);
                        if (bad_threshold*bad_blocks>good_blocks) then
                        begin
                            new_header_ch:=SOH;
                            block_size:=128;
                            if use_crc then
                                block_len:=block_size+2
                            else
                                block_len:=block_size+1
                        end
                    end
                end
            end
        until (EOF_xfile) or (tries=max_tries) or (inch=ord(CAN)) or stop_send;
        if stop_send then
            if c_carrier(cp) then cancel_transfer;
        if tries>=max_tries then
            writeln('No ACK ever received.')
        else if inch=ord(CAN) then
            writeln('Receiver cancelled transmission.')
        else if not stop_send then
        begin
            write('Waiting for ACK on EOT ---     '+BS+BS+BS+BS);
            tries:=0;
            repeat
                c_putc(cp,EOT);
                inc(tries);
                inch:=c_getb(cp,ten_seconds);
                if inch=ord(CAN) then inch:=c_getb(cp,ten_seconds);
                stop_send:=stop_send or (inch=-2)
      until (inch=ord(ACK)) or
                        (tries=max_tries) or
                        (inch=ord(CAN)) or
                        stop_send;
            if tries=max_tries then
                writeln('Not Received.')
            else if (inch=ord(CAN)) then
                writeln('Receiver Cancelled.')
            else if (stop_send) then
                writeln('Transfer Cancelled.')
            else
            begin
                writeln('Received.');
                writeln('  Sent file '+filename);
                inc(successful)
            end
    end;
        close(xfile)
    end;


  procedure send_ymodem;

    procedure get_unix_style_date(var date : longint;
                                                                  year,
                                                                    month,
                                                                    day,
                                                                    hour,
                                                                    mins,
                                                                    secs : word);

      const secs_per_year      = 31536000;
                    secs_per_leap_year = 31622400;
                    secs_per_day       = 86400;
                    secs_per_hour      = 3600;
                    secs_per_minute    = 60;
                    GMT_difference     = -7;

      var rdate,
                t         : longint;
                leap_year : boolean;
                i         : word;

        const
                days_per_month: array [1..12] of byte =
                    (31,28,31,30,31,30,31,31,30,31,30,31);

      begin
        date:=GMT_difference * secs_per_hour;
            for i:=1970 to (year-1) do
            begin
                if (i mod 4)=0 then
                    t:=secs_per_leap_year
                else
                    t:=secs_per_year;
                date:=date+t
            end;
            if (year mod 4)=0 then
                days_per_month[2]:=29
            else
                days_per_month[2]:=28;
            for i:=1 to month-1 do
                date:=date+days_per_month[i]*secs_per_day;
            date:=date+(day-1)*secs_per_day+
                                                 hour*secs_per_hour+
                                                 mins*secs_per_minute+secs
      end;


      procedure make_ymodem_header;
        var i,
                j,
                k,
                l,
                crc   : word;
                inch  : integer;
                remo,
                quot,
                date  : longint;
                C_file_size,
                octd  : string[20];
                fdate : datetime;

        function lowercase(c:char):char;
            begin
                if c in ['A'..'Z'] then
                    lowercase:=chr(ord(c)+32)
                else
                    lowercase:=c
            end;

      begin
            fillchar(block,130,#0);
        l:=length(filename);
            for i:=1 to l do block[i]:=lowercase(filename[i]);
        str(file_entry.size:10,c_file_size);
            j:=1;
            while(C_file_size[j]=' ') do inc(j);
            i:=l+2;
            for k:=j to 10 do
            begin
                block[i]:=c_file_size[k];
                inc(i)
            end;
        unpacktime(file_entry.time,fdate);
            with fdate do get_unix_style_date(date,year,month,day,hour,min,sec);
        octd:='';
            repeat
                quot:=date div 8;
                remo:=date-8*quot;
                octd:=chr(remo+ord('0'))+octd;
                date:=quot
            until date<=0;
            block[i]:=' ';
            for k:=1 to length(octd) do
            begin
            inc(i);
                block[i]:=octd[k]
            end
        end;

    procedure send_null_file_name;
        var i : word;
        begin
            repeat
                inch:=c_getb(cp,one_second)
            until (inch=timeout);
            c_putc(cp,SOH);
            c_putc(cp,#0);
            c_putc(cp,#255);
            for i:=1 to 130 do c_putc(cp,#0);
            writeln('Sending Null file name to terminate batch transfer...');
            inch:=c_getb(cp,ten_seconds);
            if(inch=ord(ACK)) then
            begin
                writeln('');
                writeln('  Receiver ACKnowledged end of batch.')
            end
        end;

  begin
        writeln('Batch file upload using Ymodem.');
        filename:=getfile(cp);
    stop_send:=(filename='');
        if stop_send then
            writeln('No files to send.');
        while not stop_send do
        begin
            findfirst(filename,32,file_entry);
            if doserror=0 then
            begin
                if not stop_send then make_ymodem_header;
                if not stop_send then
                begin
                    writeln('Uploading: '+filename);
                    send_xmodem(true)
                end
            end;
      filename:=getfile(cp);
            stop_send:=stop_send or (filename='')
        end;
        send_null_file_name;
        writeln('Ymodem batch transfer complete.');
    end;

  procedure send_modem7(use_crc:boolean);
    var checksum : word;
            ack_ok   : boolean;

      procedure make_telink_header;
        var i,
                j,
                l        : word;
                inch     : integer;
        begin
          fillchar(block,130,#0);
            meml[seg(block):ofs(block[1])]:=file_entry.size;
            meml[seg(block):ofs(block[5])]:=file_entry.time;
            l:=length(filename);
            for i:=1 to l do block[i+8]:=filename[i];
            for i:=(l+1) to 16 do block[i+8]:=' ';
            move(bbsname[1],block[26],16)
        end;

      procedure wait_for_NAK;
        begin
            i:=0;
            repeat
                inch:=c_getb(cp,one_second);
                inc(i)
            until (inch=ord(NAK)) or
                        (i>=60) or
                        stop_send;
            if inch<>ord(NAK) then
            begin
                stop_send:=true;
                writeln('   NAK for start of file name not received;');
                writeln('   Received Ascii ',inch:4,' instead.')
            end
            else
            begin
                writeln('   NAK for start of file name received.');
                c_putc(cp,ACK)
            end;
            c_flush_in(cp)
        end;

    procedure send_file_name;
        var modem7_name : string[11];
                p           : byte;
        begin
      fillchar(modem7_name[1],11,#32);
            p:=pos('.',filename);
            if p>0 then
            begin
                move(filename[1],modem7_name[1],p-1);
                move(filename[p+1],modem7_name[9],ord(filename[0])-p)
            end
            else move(filename[1],modem7_name[1],ord(filename[0]));
            i:=0;
            checksum:=0;
            while(not stop_send) and (i<11) do
            begin
                inc(i);
                checksum:=(checksum+ord(modem7_name[i])) mod 256;
                c_putc(cp,modem7_name[i]);
                inch:=c_getb(cp,ten_seconds);
                ack_ok:=(inch=ord(ACK));
                stop_send:=stop_send or (not ack_ok)
            end;
            if not stop_send then
            begin
                checksum:=(checksum+ord(SUB)) mod 256;
                c_putc(cp,SUB);
                inch:=c_getb(cp,ten_seconds);
                if inch<>checksum then
                begin
                    stop_send:=true;
                    writeln('   Received checksum for file name not correct;');
                    writeln('   Correct checksum = ',checksum:6,', received ',inch:6)
                end
                else c_putc(cp,ACK)
            end
        end;

  begin
        case transfer of
            telink     : tname:='* Telink';
            modem7_chk : tname:='* Modem7 (checksum)';
            modem7_crc : tname:='* Modem7 (CRC)'
        end;
    use_crc:=use_crc or (transfer=telink);
        writeln('Batch file upload using '+tname);
        filename:=getfile(cp);
        stop_send:=filename='';
        if stop_send then
            writeln('No files found to send.');
        while not stop_send do
        begin
            findfirst(filename,32,file_entry);
            if doserror=0 then
            begin
        if not stop_send then wait_for_nak;
                if not stop_send then send_file_name;
                if not stop_send then
                begin
                    if transfer=telink then make_telink_header;
                    if not stop_send then send_xmodem(use_crc)
                end
            end;
            filename:=getfile(cp);
            stop_send:=stop_send or (filename='')
        end;
        c_putc(cp,EOT);
        inch:=c_getb(cp,500);
        if inch=ord(ACK) then
            writeln('  Receiver ACKnowledged EOT.');
    end;

begin
  successful:=0;
  case transfer of
        xmodem_chk   :begin
                                      filename:=getfile(cp);
                                      send_xmodem(false)
                                  end;
        xmodem_crc   :begin
                                      filename:=getfile(cp);
                                      send_xmodem(true)
                                  end;
        telink       :send_modem7(true);
        modem7_chk   :send_modem7(false);
        modem7_crc   :send_modem7(true);
        ymodem       :begin
                                      filename:=getfile(cp);
                                      send_xmodem(true)
                                  end;
        ymodem_batch :send_ymodem
    end;
    tmodem7:=successful
end;


function rmodem7;

type memarray    = array [0..65000] of char;

const max_write_buffer = 2048;

var block        : array [1..2048] of char;
    file_entry   : searchrec;
        null_file_name,
        stop_receive : boolean;
        filename     : filestr;
        block_num    : byte;
        write_buffer : ^memarray;
        successful   : word;


  procedure receive_xmodem(use_crc:boolean);

    const max_errors = 20;

  var
        block_count,
        i,
        error_count,
        inch,
        ch,
        block_len,
        blockl_errors,
        SOH_errors,
        blockn_errors,
        comple_errors,
        timeout_errors,
        resend_errors,
        CRC_errors,
        crc_tries,
        SOH_time,
        write_count,
        err,
        buffer_pos,
        blocks_to_get,
        buffer_length   : integer;
        block_comp,
        block_prev,
        block_prev1     : byte;
        error_flag,
        truncate_file,
        RFile_open,
        OK_transfer,
        block_zero,
        Use_crc_2,
        long_buffer     : boolean;
        rfile_name,
        tname           : string;
        rfile_size_2,
        rfile_size      : longint;
        xfile           : file;


    procedure open_receiving_file;
        begin
            if filename='' then filename:=getfile(cp);
            if not rfile_open then
            begin
                assign(xfile,path+'\'+filename);
                rewrite(xfile,1);
                if ioresult<>0 then
                begin
                    writeln('Cannot open specified file for reception.');
                    stop_receive:=true
                end
                else rfile_open:=true
            end;
            if rfile_open then writeln('Receiving file '+filename)
        end;

    function receive_block(use_crc:boolean):boolean;

    var crc,
                checksum,
                i         : word;
        begin
            receive_block:=false;
            checksum:=0;
            crc:=0;
            for i:=1 to block_len do
            begin
                ch:=c_getb(cp,one_second);
                if ch=timeout then
                begin
                    inc(blockl_errors);
                    writeln('Block Length Error.')
                end;
                block[i]:=chr(ch);
                if use_crc then
                    crc:=crc_update(crc,ch)
                else
          checksum:=(checksum+ch) and 255
            end;
            if use_crc then
            begin
                ch:=c_getb(cp,one_second);
                if ch<>timeout then
                begin
                    crc:=CRC_update(CRC,ch);
                    ch:=c_getb(cp,one_second);
          if ch<>timeout then
                    begin
                        crc:=CRC_update(crc,ch);
                        receive_block:=(crc=0)
                    end
                    else
                    begin
            inc(blockl_errors);
                        writeln('Block Length Error ',blockl_errors:5)
                    end
                end
                else
                begin
                    inc(blockl_errors);
                    writeln('Block Length Error ',blockl_errors:5)
                end
            end
            else
            begin
                ch:=c_getb(cp,one_second);
                receive_block:=(checksum=ch)
            end
        end;

      procedure receive_telink_header;
        var i : word;
        begin
      rfile_size:=0;
            rfile_name:='';
            for i:=4 downto 1 do
                rfile_size:=rfile_size*256+ord(block[i]);
            blocks_to_get:=round((rfile_size div 128)+0.49);
            for i:=9 to 24 do
                if block[i]<>#0 then
                    rfile_name:=rfile_name+block[i];
      while (length(rfile_name)>0) and
            (rfile_name[length(rfile_name)]=' ') do dec(rfile_name[0]);
            i:=0;
      findfirst(path+rfile_name,readonly+sysfile+hidden+archive,file_entry);
            if doserror=0 then
            begin
                writeln('File collision');
                repeat
                    rfile_name[length(rfile_name)]:=chr(ord('0')+i);
                    inc(i);
                    findfirst(path+rfile_name,readonly+sysfile+hidden+archive,file_entry)
                until (doserror<>0) or (i>=10);
                stop_receive:=(i>=10)
            end;
            if not stop_receive then
            begin
        writeln('File name:           '+filename);
              writeln('File Size in bytes:  ',rfile_size:8);
              writeln('File Size in blocks: ',blocks_to_get:8);
              if rfile_size>0 then truncate_file:=true
            end
      else writeln('Nonrecoverable file collision')
        end;

    procedure receive_ymodem_header;
    var i,j    : word;
        begin
            rfile_size:=0;
            rfile_name:='';
      i:=1;
      while(block[i]<>#0) do
            begin
                rfile_name:=rfile_name+upcase(block[i]);
                inc(i)
            end;
      if rfile_name='' then
            begin
                null_file_name:=true;
                exit
            end;
            inc(i);
            while(block[i]<>#0) and (block[i]<>' ') do
            begin
                rfile_size:=rfile_size*10+ord(block[i])-ord('0');
                inc(i)
            end;
            inc(i);
            while (block[i]<>#0) and (block[i]<>' ') do inc(i);
            j:=0;
      findfirst(path+rfile_name,readonly+sysfile+hidden+archive,file_entry);
            if doserror=0 then
            begin
                writeln('File collision');
                repeat
                    rfile_name[length(rfile_name)]:=chr(ord('0')+j);
                    inc(j);
                    findfirst(path+rfile_name,readonly+sysfile+hidden+archive,file_entry)
                until (doserror<>0) or (j>=10);
                stop_receive:=(j>=10)
            end;
            filename:=rfile_name;
            if not stop_receive then
            begin
              writeln(' File name:              '+filename);
        blocks_to_get:=round(rfile_size/1024+0.49);
                if rfile_size>0 then
                begin
          writeln(' File size in bytes:     ',rfile_size:8);
                    writeln(' File size in 1K blocks: ',blocks_to_get:8)
                end;
                blocks_to_get:=round(rfile_size/128+0.49);
        if rfile_size>0 then truncate_file:=true;
                open_receiving_file
            end
        end;

    procedure wait_for_soh(wait_time:word;var inch:integer);
    var itime : word;
        begin
            inch:=timeout;
            if stop_receive then exit;
            itime:=0;
            repeat
                inc(itime);
                inch:=c_getb(cp,one_second);
                if not c_carrier(cp) then
                begin
                    stop_receive:=true;
                    inch:=timeout
                end
            until (stop_receive or (itime>wait_time) or (inch<>timeout))
        end;

    procedure write_file_data;

            procedure do_actual_write(write_count:integer);
            begin
                writeln('Writing.');
                if((rfile_size_2+write_count)>rfile_size) and truncate_file then
                    write_count:=trunc(rfile_size-rfile_size_2);
                blockwrite(xfile,write_buffer^,write_count);
                if (ioresult<>0) then
                begin
                    writeln('Error writing to disk, transfer cancelled.');
                    stop_receive:=true
                end;
                rfile_size_2:=rfile_size_2+write_count
            end;

        begin
            if (not long_buffer) then
                do_actual_write(block_len)
            else
            begin
                if(buffer_pos+block_len)>max_write_buffer then
                begin
                    do_actual_write(buffer_pos);
                    buffer_pos:=0
                end;
                move(block,write_buffer^[buffer_pos],block_len);
                buffer_pos:=buffer_pos+block_len
            end
        end;

    procedure cancel_transfer;
        begin
            c_flush_in(cp);
            c_putc(cp,CAN);
            c_putc(cp,CAN);
            c_putc(cp,CAN);
            c_putc(cp,CAN);
      c_putc(cp,CAN);

      c_putc(cp,BS);
            c_putc(cp,BS);
            c_putc(cp,BS);
            c_putc(cp,BS);
      c_putc(cp,BS)
        end;

  begin
    case transfer of
            xmodem_chk      : tname:='Xmodem (checksum)';
            xmodem_CRC      : tname:='Xmodem (CRC)';
            telink          : tname:='Telink';
            modem7_chk      : tname:='Modem7 (checksum)';
            modem7_CRC      : tname:='Modem7 (CRC)';
            ymodem          : tname:='Ymodem';
            ymodem_batch    : tname:='Ymodem Batch'
      end;
        if filename='' then
            writeln('Receive file using '+tname)
        else
            writeln('Receive file '+filename+' using '+tname);
        soh_errors:=0;
        blockl_errors:=0;
        blockn_errors:=0;
        comple_errors:=0;
        timeout_errors:=0;
        resend_errors:=0;
        crc_errors:=0;
    block_num:=0;
        block_count:=0;
        block_prev:=0;
        block_len:=128;
        error_count:=0;
        crc_tries:=0;
        soh_time:=10;
        truncate_file:=false;
        rfile_size:=0;
        rfile_size_2:=0;
    rfile_name:='';
        ok_transfer:=false;
        block_zero:=false;
    stop_receive:=false;
        null_file_name:=false;
        if (max_write_buffer>1024) and
             (max_write_buffer<maxavail) then
        begin
            buffer_length:=max_write_buffer;
            long_buffer:=true;
            getmem(write_buffer,buffer_length)
        end
        else
        begin
            long_buffer:=false;
            buffer_length:=1024;
            write_buffer:=@block
        end;
        buffer_pos:=0;
        rfile_open:=false;
        if filename<>'' then
        begin
            open_receiving_file;
            if stop_receive  then
            begin
                cancel_transfer;
                exit
            end
        end
        else if (filename='') and
                 (transfer in [xmodem_chk,xmodem_crc,ymodem]) then
             open_receiving_file;
        repeat
            error_flag:=false;
      repeat
                if block_count=0 then
                begin
                    use_crc:=use_crc and (crc_tries<4);
                    c_flush_in(cp);
                    if use_crc then
                        c_putc(cp,'C')
                    else
                      c_putc(cp,NAK);
                    inc(crc_tries);
                end;
                wait_for_soh(soh_time,inch);
                if inch=ord(CAN) then
                    wait_for_soh(soh_time,inch)
            until (inch=ord(SOH)) or
                        (inch=ord(EOT)) or
                        (inch=ord(CAN)) or
                        (inch=ord(SYN)) or
                        (inch=ord(STX)) or
                        (inch=timeout)       or
                        (error_count>max_errors) or
                        (stop_receive);
            if stop_receive then
            begin
                if not c_carrier(cp) then
                begin
                    writeln('Carrier Dropped.');
                end
            end
            else
            begin
                if inch=timeout then
                begin
                    inc(timeout_errors);
                    writeln('Timeout Errors ',timeout_errors:5)
                end
                else
                begin
                    if (inch=ord(SOH)) or
                         (inch=ord(SYN)) or
                         (inch=ord(STX)) then
                    begin
                        if inch=ord(STX) then
                            block_len:=1024
                        else
                            block_len:=128;
                        ch:=c_getb(cp,one_second);
                        if ch=timeout then
                        begin
                            inc(blockl_errors);
                            writeln('Short Block')
                        end;
                        block_num:=ch;
                        ch:=c_getb(cp,one_second);
                        if ch=timeout then
                        begin
                            inc(blockl_errors);
                            writeln('Short Block')
                        end;
                        block_comp:=ch;
                        if ((block_num+block_comp)=255) then
                        begin
                            block_prev1:=block_prev+1;
                            block_zero:=(block_count=0) and
                                                    (block_num=0)   and
                                                    ((inch=ord(SYN)) or
                                                    (transfer in [ymodem,ymodem_batch]));
                            if (block_num=block_prev1) or block_zero then
                            begin
                                use_crc_2:=use_crc and (not (block_zero and (transfer=telink)));
                                if receive_block(use_crc_2) then
                                begin
                                    if (not block_zero) then
                                    begin
                                        write_file_data;
                                        error_count:=0;
                                        inc(block_count);
                                        write('Block ',block_count:5,#13);
                                        block_prev:=block_num;
                                        c_putc(cp,ACK)
                                    end
                                    else
                                    begin
                                        if inch=ord(SYN) then
                                            receive_telink_header
                                        else if (transfer in [Ymodem,Ymodem_batch]) then
                                                 receive_ymodem_header;
                                        if not stop_receive then
                                        begin
                                            c_putc(cp,ACK);
                                            error_count:=0
                                        end
                                    end
                                end
                                else
                                begin
                                    inc(crc_errors);
                                    if use_crc then
                                      writeln('CRC error ',crc_errors:5)
                                    else
                                        writeln('Checksum error ',crc_errors:5)
                                end
                          end
                            else
                            begin
                                if (block_num=block_prev) then
                                begin
                                    inc(resend_errors);
                                    writeln('Duplicate Block ',resend_errors:5);
                                    c_putc(cp,ACK)
                                end
                                else
                                begin
                                    inc(blockn_errors);
                                    writeln('Synchronization Error ',blockn_errors:5)
                                end
                    end
                        end
                      else
                      begin
                          inc(comple_errors);
                          writeln('Sector Number error ',comple_errors:5)
                      end
                  end
            else
                  begin
                        if (inch<>ord(EOT)) then
                        begin
                            inc(soh_errors);
                            writeln('SOH error ',soh_errors:5);
                        end
                    end;
                    if error_flag then
                    begin
                        inc(error_count);
                        c_flush_in(cp);
                        c_putc(cp,NAK)
                    end
        end
            end
    until (inch=ord(EOT)    ) or
                    (inch=ord(CAN)    ) or
                    (stop_receive     ) or
                    (null_file_name   ) or
                    (error_count>max_errors);
        if stop_receive then
            cancel_transfer
        else
        begin
            if null_file_name then
            begin
                writeln('Null file name received.')
            end
            else
            begin
                if (inch=ord(EOT)) and (error_count<=max_errors) then
                begin
                    c_putc(cp,ACK);
                    if buffer_pos>0 then
                    begin
                        write_count:=buffer_pos;
                        if((rfile_size_2+write_count)>rfile_size) and truncate_file then
                            write_count:=trunc(rfile_size-rfile_size_2);
                        blockwrite(xfile,write_buffer^,write_count);
                        if ioresult<>0 then
                        begin
                            writeln('Error in writing to disk, file may be bad.');
                        end;
                        rfile_size_2:=rfile_size_2+write_count
                  end;
                    writeln('Transfer Complete; ');
                    if rfile_size>0 then
                        if rfile_size<=rfile_size_2 then
                          rfile_size_2:=rfile_size;
                    inc(successful);
                    ok_transfer:=true;
                    writeln('Received file '+filename);
                    addfile(cp,filename)
                end
                else
                begin
                    if (inch=ord(CAN)) then
                        writeln('Transmitter cancelled file transfer.')
                else
                    writeln('Transfer cancelled.')
                end
            end
        end;
        close(xfile);
        if long_buffer then freemem(write_buffer,buffer_length)
    end;

  procedure receive_ymodem;
    begin
        stop_receive:=false;
        null_file_name:=false;
        while((not stop_receive) and (not null_file_name)) do
        begin
            filename:='';
            receive_xmodem(true);
            if ((not null_file_name) and (not stop_receive)) then
                writeln('  Received file: '+filename)
        end;
        if null_file_name then
        begin
            writeln('  Received null file name from sender.')
        end
    end;


  procedure receive_modem7(use_crc:boolean);
    const
        maxtry =5;
        maxnoise=10;

  var
        rfilename : string;
        inch,
        inch_save,
        checksum,
        i,
        j,
        tries,
        ntries    : integer;
        ch        : char;
        endfname  : boolean;
        tname     : string[10];

  begin
        case transfer of
            telink     : tname:='Telink';
            modem7_chk : tname:='Modem7 (checksum)';
            modem7_crc : tname:='Modem7 (CRC)'
        end;
        use_crc:=use_crc or (transfer=telink);
        writeln('Batch receive using '+tname);
        stop_receive:=false;
        tries:=0;
        c_flush_in(cp);
        repeat
            checksum:=0;
            rfilename:='';
            repeat
                c_putc(cp,NAK);
                ntries:=0;
                repeat
                    inch:=c_getb(cp,200);
                    inc(ntries)
                until (ntries>maxnoise) or
                            (inch<=127) or
                            stop_receive;
              inc(tries)
            until(inch=ord(ACK)) or
                     (inch=ord(EOT)) or
                     (inch=ord(CAN)) or
                     (tries>maxtry) or
                     stop_receive;
            stop_receive:=(inch<>ord(ACK)) or stop_receive;
            inch_save:=inch;
            if not stop_receive then
              repeat
                    inch:=c_getb(cp,500);
                    endfname:=(inch=ord(CAN)) or
                                        (inch=ord(EOT)) or
                                        (inch=timeout) or
                                        (inch=ord(SUB)) or
                                        stop_receive;
                    if not endfname then
                    begin
                        c_putc(cp,ACK);
                        rfilename:=rfilename+chr(inch);
                        checksum:=(checksum+inch) and 255
                    end
        until endfname
            else
                inch:=timeout;
      if inch=ord(SUB) then
            begin
                checksum:=(checksum+inch) and 255;
                c_putc(cp,chr(checksum));
                inch:=c_getb(cp,ten_seconds);
                if (inch=ord(ACK)) and (not stop_receive) then
                begin
                    for i:=length(rfilename) to 11 do
                        rfilename:=rfilename+' ';
                    move(rfilename[9],rfilename[10],3);
                    rfilename[9]:=' ';
          while rfilename[1]=' ' do rfilename:=copy(rfilename,2,12);
          while pos('  ',rfilename)>0 do
            rfilename:=copy(rfilename,1,pos('  ',rfilename))+
                       copy(rfilename,pos('  ',rfilename)+1,12);
                    if pos(' ',filename)>0 then filename[pos(' ',filename)]:='.';
                    j:=0;
              findfirst(path+filename,readonly+sysfile+hidden+archive,file_entry);
                    if doserror=0 then
                    begin
                        writeln('File collision');
                        repeat
                            filename[length(filename)]:=chr(ord('0')+j);
                            inc(j);
                            findfirst(path+filename,readonly+sysfile+hidden+archive,file_entry)
                        until (doserror<>0) or (j>=10);
                        stop_receive:=(j>=10)
                    end;
                    if not stop_receive then
                    begin
                        writeln('  Receiving: '+filename);
                        receive_xmodem(use_crc)
                    end
                end
                else stop_receive:=true
            end
            else stop_receive:=true
        until stop_receive;
        if inch_save=ord(EOT) then
        begin
            c_putc(cp,ACK);
            writeln('Received EOT from sender.')
        end
        else
        begin
            writeln('Transfer Cancelled.')
        end
    end;


begin
  filename:='';
  successful:=0;
  case transfer of
        xmodem_chk   : receive_xmodem(FALSE);
        xmodem_crc   : receive_xmodem(TRUE);
        telink       : receive_modem7(TRUE);
        modem7_chk   : receive_modem7(FALSE);
        modem7_CRC   : receive_modem7(TRUE);
        ymodem       : receive_ymodem;
        ymodem_batch : receive_ymodem
    end;
    rmodem7:=successful
end;

var i : porttype;

begin
  for i:=com0 to com8 do head[i]:=nil
end.