CP/M/CPM_CDROM.iso/beehive/bbs/rosuncr.arc/ROSSND.INC

Text File | 1991-08-11 | 15KB | 451 lines

{ ROSSND.INC - Remote Operating System File Send Routines }

{ 14dec87 wb - chain to ROSUNCR.CHN for uncrunching files

  13nov86 wb - 1k packet vers.
}

overlay procedure SendXmodem;
{ Send a file using Xmodem protocol }
  const
    STX = #$02;

  var
    OK: boolean;
    this: FilePtr;
    XfrName: FileName;
    XfrFile: untype_file;
    Buffer: array[1..1024] of byte;
    TPL: char;
    KPacket: boolean;
    packet_size: integer;

   procedure SendFile(var XfrFile: untype_file; remaining: integer);
    const
      maxerr = 10;
    var
      CRCmode, timeout: boolean;
      bt: byte;
      ch: char;
      mm, ss, time_on, time_left, i, vv, block, block2, errcnt: integer;

    begin
      timer(time_on, time_left);
      send_time(remaining, mm, ss);
      if mm > time_left
        then
          begin
            writeln(USR, 'Insufficient time remaining for transfer.');
            OK := FALSE
          end
        else
          begin
            errcnt := 0;
            block := 1;
            writeln(USR, XfrName, ' contains ', remaining, ' blocks.');
            writeln(USR, 'Send time: ', mm, ' minutes ',ss, ' seconds at ', rate, ' bps.');
            writeln(USR, 'To cancel, type CTL-X.');
            writeln(USR, 'Ready to send...');

            block2 := remaining;

            if KPacket then
            begin
              TPL := STX;
              packet_size := 1024;
            end
            else
            begin
              TPL := SOH;
              packet_size := 128;
            end;


            repeat
              bt := GetByte(10, timeout);
              CRCmode := (bt = ord('C'));
              if CRCmode
                then
                  begin
                    writeln('CRC mode requested.');
                    errcnt := 0
                  end
              else if bt = ord(NAK)
                then
                  begin
                    writeln('Checksum mode requested.');
                    errcnt := 0
                  end
              else if bt = ord(CAN)
                then errcnt := maxerr
                else errcnt := succ(errcnt)
            until (errcnt = 0) or (errcnt >= maxerr);
            while (remaining > 0) and (errcnt < maxerr) do
              begin
                if remaining < 8 then
                begin
                  KPacket := False;
                  TPL := SOH;
                  Packet_Size := 128;
                end;
                if KPacket then
                  blockread(XfrFile, Buffer, 8)
                else
                  blockread(XfrFile, Buffer, BufBlocks);
                if KPacket then
                  remaining := remaining - 8
                else
                  remaining := pred(remaining);
                repeat
                  vv := 0;
                  if CRCmode
                    then
                      begin
                        for i := 1 to packet_size do
                          updcrc(vv, Buffer[i]);
                        updcrc(vv, 0);
                        updcrc(vv, 0)
                      end
                    else for i := 1 to packet_size do
                           vv := vv + Buffer[i];
                  writeln('vv= ',vv);
                  PutByte(ord(TPL));
                  PutByte(lo(block));
                  PutByte(not lo(block));
                  for i := 1 to packet_size do
                    PutByte(Buffer[i]);
                  if CRCmode
                    then PutByte(hi(vv));
                  PutByte(lo(vv));
                  repeat
                    bt := GetByte(12, timeout);
                    if bt = ord(ACK)
                      then
                        begin
                          write(CR, 'Block sent: ');  { Local display of what is happening }
                          if KPacket then
                            write(block * 8 - 7,'-',block * 8)
                          else
                            write(block2 - remaining);
                          ClrEol;
                          block := succ(block);
                          errcnt := 0
                        end
                    else if (bt = ord(NAK)) or timeout
                      then
                        begin
                          if bt = ord(NAK)
                            then write('  ++ NAK received')
                          else if timeout
                            then write('  ++ Timeout');
                          errcnt := succ(errcnt);
                          writeln(' - error ', errcnt, ' ++')
                        end
                    else if bt = ord(CAN)
                      then errcnt := maxerr;
                    ch := GetChar           { Monitor local console }
                  until (bt in [ord(ACK), ord(NAK), ord(CAN)]) or timeout
                until (errcnt = 0) or (errcnt >= maxerr)
              end;
            writeln;
            OK := (errcnt = 0);
            if OK
              then
                begin
                  repeat
                    PutByte(ord(EOT));
                    if ord(ACK) = GetByte(10, timeout)
                      then errcnt := 0
                      else errcnt := succ(errcnt)
                  until (errcnt = 0) or (errcnt >= maxerr);
                  bt := GetByte(2, timeout);
                  OK := (errcnt = 0);
                  if OK
                    then writeln(USR, 'Transfer complete.')
                    else writeln(USR, 'End of file not acknowledged.')
                end
              else writeln(USR, 'Transfer cancelled.')
          end;
    end;

  begin { SendXmodem }
    XfrName := correct_fn(prompt('File name', 12, 'ES'));
    KPacket := ask('1k Packets');
    if XfrName <> ''
      then
        begin
          if in_library
            then this := LibBase
            else this := DirBase;
          while (this <> nil) and (XfrName <> compress_fn(this^.fname)) do
            this := this^.next;
          if this <> nil
            then
              begin
                log(5, XfrName);
                SetSect(SetDrv, SetUsr);
                if in_library
                  then
                    begin
                      seek(libr_file, this^.index);
                      SendFile(libr_file, this^.fsize)
                    end
                  else
                    begin
                      Assign(XfrFile, XfrName);
                      Reset(XfrFile);
                      SendFile(XfrFile, FileSize(XfrFile));
                      Close(XfrFile)
                    end;
                SetSect(HomDrv, HomUsr);
                if OK
                  then
                    begin
                      log(7, '');
                      user_rec.download := succ(user_rec.download)
                    end
                  else log(8, '')
              end
            else writeln(USR, XfrName, ' not found.')
        end
  end;

overlay procedure SendText;
  var
    this: FilePtr;

{ Made these variables global to pass file to ROSUNCR.CHN
    XfrName: FileName;
    XfrFile: untype_file;
}

  procedure SendFile(var XfrFile: untype_file; remaining: integer);
  { Send a squeezed, crunched or ASCII file }
    const
      recognize = $FF76;
      DLE       = $90;
    var
      EndOfFile, squeezed, crunched : boolean;
      i, x, BufferPtr, bpos, curin, repct, lastc, NoOfRecs, line_count: integer;
      FileType: String[3];
      ErrMsg: StrPr;
      dnode: array [0..255, 0..1] of integer;

    function getc: integer;
    { Get an 8 bit value from the input buffer - read block if necessary }
      begin
        if BufferPtr > BufSize
          then
            begin
              NoOfRecs := min(BufBlocks, remaining);
              EndOfFile := (NoOfRecs = 0);
              if not EndOfFile
                then
                  begin
                    {$I-} BlockRead(XfrFile, Buffer, NoOfRecs) {$I+};
                    EndOfFile := (IOresult <> 0)
                  end;
              remaining := remaining - NoOfRecs;
              BufferPtr := 1
            end;
        getc := Buffer[BufferPtr];
        BufferPtr := succ(BufferPtr)
      end;

    function getw: integer;
    { Get a 16 bit value from the input buffer }
      begin
        getw := getc + Swap(getc)
      end;

    procedure BuildTree;
    { Build decode tree }
      var
        i, CheckSum, numnodes: integer;
      begin
        ErrMsg := '';
        if recognize = getw                 { Is it really a squeezed file? }
          then
            begin
              CheckSum := getw;             { Get checksum }
              XfrName := '';
              i := getc;                    { Build original file name }
              while i <> 0 do
                begin
                  XfrName := XfrName + UpCase(chr(i));
                  i := getc
                end;
              numnodes := getw;             { Get the number of nodes in tree }
              if (0 < numnodes) and (numnodes <= 256)
                then for i := 0 to pred(numnodes) do
                  begin
                    dnode[i, 0] := getw;
                    dnode[i, 1] := getw;
                  end
                else
                  begin
                    ErrMsg := 'Invalid decode tree size.';
                    squeezed := FALSE
                  end
            end
          else squeezed := FALSE
      end;

    function gethuff: integer;
    { Get character coding }
      var
        i: integer;
      begin
        i := 0;
        repeat
          bpos := succ(bpos);
          if bpos > 7
            then
              begin
                curin := getc;
                bpos := 0
              end
            else curin := curin shr 1;
          i := dnode[i, curin and $0001]
        until i < 0;
        i := -succ(i);
        if i = 0
          then gethuff := 26
          else gethuff := i
      end;

    function getcr: integer;
      var
        c: integer;
      begin
        if repct > 0
          then
            begin
              repct := pred(repct);
              getcr := lastc
            end
          else
            begin
              c := gethuff;
              if c = DLE
                then
                  begin
                    repct := gethuff;
                    if repct = 0
                      then getcr := DLE
                      else
                        begin
                          repct := repct - 2;
                          getcr := lastc
                        end
                  end
                else
                  begin
                    getcr := c;
                    lastc := c
                  end
            end
      end;

    begin { SendFile }
      i := pos('.', XfrName);
      if i = 0
        then FileType := ''
        else FileType := copy(XfrName, succ(i), length(XfrName));
      squeezed := ('Q' = FileType[2]);
      crunched := ('Z' = FileType[2]);
      repct := 0;
      bpos := 8;
      ErrMsg := '';
      BufferPtr := MaxInt;                  { Force a read the first time }
      EndOfFile := FALSE;
      if remaining > 0
        then
          begin
            if squeezed
              then BuildTree;
            i := pos('.', XfrName);
            if 0 = i
              then FileType := ''
              else FileType := copy(XfrName, succ(i), length(XfrName));
            if (FileType = 'COM') or (FileType = 'OBJ') or
               (FileType = 'EXE') or (FileType = 'LBR')
              then ErrMsg := 'Xmodem protocol required for ".' + FileType + '" files.';
            if ErrMsg = ''
              then
                begin
                  line_count := 0;
                  if crunched then
                    begin
                      { Save heap pointers & 1st 128 bytes of heap }
                      heap_ptr:=HeapPtr;
                      heap_fre:=HeapFre;
                      setsect(HomDrv,HomUsr);
                      assign(chain_file,'ROSUNCR.CHN');
                      chain(chain_file);
                    end;
                  if squeezed
                    then
                      begin
                        writeln(USR, '      ---> ', XfrName);
                        x := getcr
                      end
                    else x := getc;
                  while (not brk) and (not EndOfFile) and (x <> 26) do
                    begin
                      write(USR, chr(x));
                      if (user_rec.lines <> 99) and (chr(x) = LF)
                        then
                          begin
                            line_count := succ(line_count);
                            if line_count mod user_rec.lines = 0
                              then pause
                          end;
                      if squeezed
                        then x := getcr
                        else x := getc
                    end
                end
          end
        else ErrMsg := 'Missing or empty input file.';
      if ErrMsg <> ''
        then writeln(USR, ErrMsg)
    end;

  begin { SendText }
    XfrName := correct_fn(prompt('File name', 12, 'ES'));
    if XfrName <> ''
      then
        begin
          if in_library
            then this := LibBase
            else this := DirBase;
          while (this <> nil) and (XfrName <> compress_fn(this^.fname)) do
            this := this^.next;
          if this <> nil
            then
              begin
                log(6, XfrName);
                SetSect(SetDrv, SetUsr);
                if in_library
                  then
                    begin
                      {$I-} seek(libr_file, this^.index) {$I+};
                      if IOresult = 0
                        then SendFile(libr_file, this^.fsize)
                    end
                  else
                    begin
                      Assign(XfrFile, XfrName);
                      Reset(XfrFile);
                      SendFile(XfrFile, FileSize(XfrFile));
                      Close(XfrFile)
                    end;
                SetSect(HomDrv, HomUsr);
                log(7, '')
              end
            else writeln(USR, XfrName, ' not found.')
        end
  end;