CP/M/CPM_CDROM.iso/beehive/bbs/picsuncr.arc/PICS2C1.UNC

Text File | 1991-08-11 | 8KB | 253 lines

{PICS2C1.unc   Pascal Integrated Communications System}
{ 5/25/87 vers. 1.6 Copywright 1987 by Les Archambault}

{ 01mar88 wb - Made Buffer, XfrName & XfrFile global variables and
  modified SendFile procedure to chain to PICSUNCR.CHN for uncrunch
  support. Renamed from PICS2c1.inc to PICS2c1.unc }

overlay procedure SendText;
  var
    this: FilePtr;

  procedure SendFile(var XfrFile: untype_file; remaining: integer);
  { Send a squeezed, crunched or ASCII file }
    const
      recognize = $FF76;
      DLE       = $90;
    var
      EndOfFile, squeezed,crunched,page: 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
            line_count := 0;
            if crunched then
              begin
                { Save heap pointers }
                heap_ptr:=HeapPtr;
                heap_fre:=HeapFre;
                setsect(HomDrv,HomUsr);
                assign(chain_file,'PICSUNCR.CHN');
                chain(chain_file);
              end;
            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[2]='Z') or
               (FileType = 'EXE') or (FileType = 'LBR') or (FileType='ARC')
              then ErrMsg := 'Xmodem protocol required for ".' + FileType + '" files.';
            if ErrMsg = ''
              then
                begin
                  page:=ask('Do you want page breaks');
                  line_count := 0;
                  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) and (page)
                        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 }
   if (not in_arc) then
   begin
    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
                setsect(homdrv,homusr);
                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  {not in arc}
   else
     begin
       writeln(usr);
       writeln(usr,'Unable to type Arc file members.');
     end;
  end;

{end of PICS2C1.unc }