Frostbyte's 1980s DOS Shareware Collection/floppyshareware.zip/floppyshareware/USCX/TBBS8502.ARC/FILESYS.INC

Text File | 1985-10-06 | 25KB | 850 lines

(* ------------------------------------------------ FILESYS.INC ---------------------------------------------------*)

PROCEDURE filesys;

  const
    mostfiles = 200;
    soh = 1;
    stx = 2;
    eot = 4;
    ack = 6;
    nak = $15;
    can = $18;
    C   = $43;
    ksize = 1; {minimum increment of file size in Kbytes}

  type
    filerec = record
               title    : name;
               submit   : integer;
               date     : name;
               size     : integer;
               accesses : integer;
               ASCII    : boolean;
               section  : byte;
               public   : boolean;
               progdesc : string[40];
             end;
    channel = array[0..127] of byte;
    channelx = array[0..1023] of byte;

  var
    filefile: file of filerec;
    filetab: array[0..mostfiles] of filerec;
    filebuff: array [0..16] of channel;
    filebuffx: channelx;
    datafile: file;
    chksum: byte;
    CRC: integer;
    ymodem,
    crcmode   : boolean;
    junk,
    enddir    : integer;
    comch     : char;
    hh, mm, ss: string[2];
    tstr      : string[8];


  PROCEDURE xmit(x:byte);
    begin
      xmitchar(chr(x));
    end;

  FUNCTION inbyte: byte;

    var temp: char;

    begin
      repeat until inready or not cts;
      if keypressed then read(kbd, temp) else temp := recvchar;
      inbyte := ord(temp);
    end;

  PROCEDURE calcCRC(data:byte);

    var
      carry: boolean;
      i: byte;

    begin
      chksum := lo(chksum + data);
      for i := 0 to 7 do begin
        carry := (crc and $8000) <> 0;
        crc := crc shl 1;
        if (data and $80) <> 0 then crc := crc or $0001;
        if carry then crc := crc xor $1021;
        data := lo(data shl 1);
      end;
    end;

  procedure soundbell;
   var
   junk : byte;

   begin
     for junk := 1 to 3 do begin
              charout(bell);
              delay(600);
              end;
   end;

  PROCEDURE sendcalc(ch : byte);

    begin
      xmit(ch);
      calcCRC(ch);
    end;

  PROCEDURE acknak(var inch: byte; time: integer);

    var loop, loopend: integer;

    begin
      loopend := 100 * time;
      loop := 0;
      inch := 0;
      repeat
        delay(10);
        if inready then inch := inbyte;
        loop :=loop + 1;
      until (inch in [ack, nak, can, C]) or (loop >= loopend) or not cts;
    end;

  FUNCTION acknakout(ch : byte): boolean;

    var  times, loops: integer;

    begin
      times := 0;
      repeat
        loops := 0;
        xmit(ch);
        while (loops < 10) and not timedin do loops := loops + 1;
        times := times + 1;
      until inready or (times > 9) or not cts;
      acknakout := inready and cts;
    end;

  PROCEDURE download (var successful: boolean);

    var
      inch: byte;
      loop, maxblock, maxxblock, numblocks, blocknum, period, tries: integer;
      done: boolean;
      temp: line;

    begin
      reset(datafile);
      if ymodem then str((filesize(datafile) div 8):4, temp) else begin
           str(filesize(datafile):4, temp);
           end;
      if not ymodem then begin
         lineout('Ready for XMODEM transfer:');
         maxblock := 127;
         maxxblock := 255;
         numblocks := 1;
         end else begin
           lineout('Ready for YMODEM transfer:');
           maxblock := 1023;
           maxxblock := 2047;
           numblocks := 8;
           end;
      lineout('File open:' + temp + ' records;');
      lineout('To cancel: type CTL-X until you return to command prompt.');
      {$I-} blockread(datafile, filebuffx[0], numblocks) {$I+};
      if IOresult <> 0 then write('');
      done := false;
      tries := 0;
      blocknum := 1;
      repeat
        acknak(inch, 60);
        if inch = 0 then inch := can;
        if inch = C then begin
          crcmode := true;
          writeln('CRC mode requested');
        end;
        if inch = ack then begin
          if eof(datafile) then done := true else begin
            write(cr + 'Sent #', blocknum:4);
            {$I-} blockread(datafile, filebuffx[0], numblocks) {$I+};
            if IOresult <> 0 then write('');
            blocknum := blocknum + 1;
            tries := 0;
          end;
        end
        else tries := tries + 1;
        if (inch <> can) and cts and not done then begin
          if ymodem then xmit(stx) else xmit(soh);
          xmit(lo(blocknum));
          xmit(maxxblock-lo(blocknum));
          chksum := 0;
          crc := 0;
          for loop := 0 to maxblock do sendcalc(filebuffx[loop]);
          calcCRC(0);
          calcCRC(0);
          if crcmode then begin xmit(hi(crc)); xmit(lo(crc)); end
            else xmit(chksum);
        end;
        if tries = 5 then crcmode := not crcmode;
        if not crcmode and (tries = 5) then begin
         ymodem := false;
         maxblock := 127;
         maxxblock := 255;
         numblocks := 1;
         end;
      until (inch = can) or done or (tries= 10) or not cts;
      successful := done;
      tries := 0;
      if successful and cts then repeat
        xmit(eot);
        acknak(inch, 10);
        tries := tries + 1;
      until (inch=ack) or (tries > 10) or not cts;
      if cts and (inch <> can) and not successful then xmit(can);
      close(datafile);
    end;


  FUNCTION recchar(var error: boolean): byte;

    var temp: byte;

    begin
      temp := 0;
      if not cts then error := true;
      if not error then begin
        if not timedin then error := true
        else begin
          temp := inbyte;
          calcCRC(temp);
          recchar := temp;
        end;
      end;
    end;

  PROCEDURE clearline;

    var junk: byte;

    begin
      while timedin do junk := inbyte;
    end;

{$I-}
  PROCEDURE upload(var successful: boolean);

    var
      blocknum, tries, byteloc : integer;
      comp, locblock, crc2     : integer;
      fatal, error, done       : boolean;
      opening, inch, locrc     : byte;
      hicrc, csum2, mode       : byte;

    begin
      lineout('Beginning XMODEM protocol upload:');
      lineout('To cancel: type CTRL-X until you return to command prompt.');
      tries := 0;
      done := false;
      opening := 0;
      locblock := 1;
      rewrite(datafile);
      fatal := ioresult > 0;
      if crcmode then mode := C else mode := nak;
      if cts and not fatal then fatal := not acknakout(mode);
      while cts and not (done or fatal) do begin
        tries := tries + 1;
        error := false;
        opening := recchar(error);
        if opening = can then fatal := true;
        if opening = eot then done := true;
        if (opening <> eot) and (opening <> soh) and not fatal
          then error := true;
        if cts and not (error or fatal or done) then begin
          blocknum := recchar(error);
          comp := recchar(error);
          if lo(comp + blocknum + opening) <> 0 then error := true;
          byteloc := 0;
          crc := 0;
          chksum := 0;
          while (byteloc < 128) and not (error or fatal) do begin
            filebuff[0][byteloc] := recchar(error);
            byteloc := byteloc + 1;
          end;
          if cts and not (error or fatal) then begin
            calcCRC(0);
            calcCRC(0);
            crc2 := crc;
            csum2 := chksum;
            hicrc := recchar(error);
            if crcmode then begin
              locrc := recchar(error);
              if (lo(crc2) <> locrc) or (hi(crc2) <> hicrc) then error := true;
            end else if csum2 <> hicrc then error := true;
            if (lo(locblock) <> blocknum)
              and (lo(locblock) <> lo(blocknum+1))
              and not error
              then fatal := true;
            if (lo(locblock) = blocknum) and not (error or fatal) then begin
              blockwrite(datafile, filebuff[0], 1);
              write(cr + ' Received #', blocknum:4);
              if IOresult <> 0 then fatal := true;
              tries := 0;
              locblock := locblock + 1;
            end;
          end;
        end;
        if not (fatal or error) then flush else clearline;
        if done or not (error or fatal) then fatal := not acknakout(ack);
        if error and not fatal then begin
          fatal := not acknakout(nak);
          if tries > 6 then crcmode := not crcmode;
        end;
      end;
      if fatal then xmit(can);
      if done then xmit(ack);
      close(datafile);
      successful := (IOresult = 0) and done and not fatal;
      if not successful then erase(datafile);
    end;

  PROCEDURE storebuff(var buffernum: byte; var paused, aborted: boolean);

    var loop: byte;

    begin
      loop := 0;
      while (loop < buffernum) and not aborted do begin
        blockwrite(datafile, filebuff[loop], 1);
        if IOresult > 0 then aborted := true;
        loop := loop + 1;
      end;
      if buffernum in [1..16] then filebuff[0] := filebuff[buffernum];
      buffernum := 0;
      repeat xmit(17) until timedin;
      paused := false;
    end;

  PROCEDURE textcap(var successful: boolean);

    var
      buffernum, where, loop  : byte;
      cc, cz, paused          : boolean;
      withecho, done, aborted : boolean;
      temp                    : byte;

    begin
      withecho := (getcap('Do you want your text echoed (Y/N) ? ') = 'Y');
      lineout('Beginning text capture: two CTRL-Cs abort, two CTRL-Zs end.');
      cc := false;
      cz := false;
      done := false;
      paused := false;
      buffernum := 0;
      where := 0;
      rewrite(datafile);
      aborted := (IOresult > 0);
      while cts and not (done or aborted) do begin
        if paused then
          if not timedin then storebuff(buffernum, paused, aborted);
        temp := inbyte;
        if not cts then aborted := true;
        if withecho and outready then xmit(temp);
        if temp = 3 then begin if cc then aborted := true else cc := true; end
          else cc := false;
        if temp = 26 then begin if cz then done := true else cz := true; end
          else cz := false;
        filebuff[buffernum][where] := temp;
        where := where + 1;
        if where > 127 then begin
          where := 0;
          buffernum := buffernum + 1;
        end;
        if buffernum > 14 then begin
          xmit(19);
          paused := true;
        end;
        if buffernum > 16 then aborted := true;
      end;
      if done and cts and not aborted then begin
        buffernum := buffernum + 1;
        storebuff(buffernum, paused, aborted);
      end;
      close(datafile);
      if aborted and (IOresult = 0) then erase(datafile);
    successful := done and (IOresult=0) and not aborted;
    end;
{$I+}

  FUNCTION exists(filename: name): boolean;

    var found: boolean;

    begin
      assign(datafile, filename);
      {$I-} reset(datafile) {$I+};
      found := (IOresult = 0);
      if found then close(datafile);
      exists := found;
    end;

  FUNCTION alpha(filename: name): boolean;

    var strpos: integer;
        okay:   boolean;
        dots:   byte;

    begin
      dots := 0;
      alpha := true;
      if length(filename) > 0 then
        for strpos := 1 to length(filename) do begin
          if filename[strpos] = '.' then dots := dots + 1;
          if not (filename[strpos] in ['.', '-', '_', '0'..'9', 'A'..'Z'])
            then alpha := false;
        end;
      if dots > 1 then alpha := false;
    end;

  FUNCTION getlegal: name;

    var filename:  name;
        dotpos: integer;
        comfile: file of line;
        head : line;

    begin
      repeat
        filename := allcaps(getinput('Enter name of file ? ', 12, echo));
        dotpos := pos('.', filename);
      until ((dotpos < 10) and (dotpos <> 1)
       and (not((dotpos = 0) and (length(filename) > 8)))
       and (not((dotpos > 0) and (length(filename) > dotpos + 3)))
       and alpha(filename))
       or (filename = '');
      getlegal := filename;

 { WRITE AN AUDIT RECORD IN THE COMMENT FILE FOR ANY FILE ACCESS }
      if (caller <> 'SYSOP') then begin
        assign(comfile, 'comments.bbs');
        {$I-} reset(comfile) {$I+};
        if IOresult <> 0 then rewrite(comfile);
        seek(comfile, filesize(comfile));
        head := caller;
        if clockin then head := head + ' ' + timeon + ' ' + filename
                   else head := head + ' ' + filename;
        write(comfile, head);
        close(comfile);
      end;
    end;

  FUNCTION dirpos(filename: name): integer;

    var loopvar: integer;

    begin
      dirpos := 0;
      loopvar := 0;
      repeat
        loopvar := loopvar + 1;
      until (filetab[loopvar].title = filename) or (loopvar >= enddir);
    if filetab[loopvar].title = filename then dirpos := loopvar;
    end;

  FUNCTION getsect: byte;

    var temp: integer;

    begin
      if sectsin then repeat
        temp := getint(numsects, 0, 'Which section (0 for all, ? for list) ? ');
        if temp = -1 then listsections else getsect := temp;
      until (temp <> -1) or not cts
      else getsect := 1;
    end;


  PROCEDURE addfile(filename: name; sectnum: byte; xmodem: boolean);

    begin
      with filetab[enddir + 1] do begin
        title    := filename;
        submit   := usernum;
        progdesc := getinput('Enter brief description of file? ', 41, echo);
        if clockin then date := timeon;
        assign(datafile, filedrive + filename);
        reset(datafile);
        size := filesize(datafile);
        close(datafile);
        accesses := 0;
        ASCII := not xmodem;
        section := sectnum;
        public := false;
      end;
    end;

  PROCEDURE newfile(xmodem: boolean);

    var
      filename: name;
      successful: boolean;
      sectnum: byte;

    begin
      clearsc;
      if access < reg then lineout('You can not send a file yet.  Use [A]pply command.')
       else begin
      if enddir >= mostfiles then lineout('No file space available.')
      else begin
        stringout('Upload: ');
        filename := getlegal;
        if filename <> '' then begin
          if exists(filedrive + filename) then lineout('File name in use.')
          else begin
            repeat sectnum := getsect until (sectnum <> 0) or not cts;
            assign(datafile, filedrive + filename);
            if cts then begin
              if xmodem then upload(successful)
                else textcap(successful);
              if successful then addfile(filename, sectnum, xmodem);
              clearline;
              if successful then enddir := enddir + 1
                else lineout('Fatal transfer error or disk full...');
            end;
          end;
        end;
      end;
    end;
   end;

  FUNCTION legaltab(prompt: line): integer;

    var filename: name;
        tabloc:   integer;

    begin
      tabloc := 0;
      clearsc;
      stringout(prompt);
      filename := getlegal;
      if filename <> '' then begin
        tabloc := dirpos(filename);
        if tabloc <> 0 then
          if not (filetab[tabloc].public or (access > paying)) then tabloc := 0;
        if tabloc <> 0 then assign(datafile, filedrive + filename)
          else if filename <> '' then lineout('No such file available.');
      end;
      legaltab := tabloc;
    end;

  PROCEDURE transmitfile;

    var
      successful: boolean;
      tabloc    : integer;
      filetime  : real;
      timeok    : boolean;
      temp      : line;

    begin
     if access < reg then lineout('You can not receive a file yet.  Use [A]pply command.')
     else begin
      timeok := false;
      calcconnect(usehour, usemin, usesec);
      tottime := (usehour * 3600) + (usemin * 60) + usesec;
      tabloc := legaltab('Download: ');
      if tabloc > 0 then begin
        {$I-} reset(datafile) {$I+};
        if IOresult = 0 then timeok := true;
        filetime := filesize(datafile) * 1.35;
        if baud = slow then filetime := filesize(datafile) * 5.4;
        str(filetime:4:0, temp);
        lineout('Transfer time ' + temp + ' seconds');
        if maxtime < (tottime + filetime) then timeok := false;
        if not timeok then lineout('Transfer time to long for time remaining') else begin
            download(successful);
            if successful then with filetab[tabloc] do begin
              accesses := accesses + 1;
              soundbell;
            end else lineout('Transfer failed.');
        end;
      end;
    end;
   end;

  procedure textdump;

    var
      junk,
      tabloc : integer;
      libname: longname;

    begin
     if access < reg then lineout('You can not receive a file yet.  Use [A]pply command.')
      else begin
      tabloc := legaltab('ASCII text dump: ');
      lineout(space);
      if tabloc > 0 then with filetab[tabloc] do begin
        libname := title;
        if pos('.LBR', title) > 1 then begin
          lineout(title + ' is a library file: please select a member: ');
          libname := getlegal;
          if libname = '' then libname := 'DIR';
          libname := copy(title, 1, length(title)-4) + '/' + libname;
        end;
        typefile(filedrive + libname, false);
        if not cancelled then begin
          soundbell;
          accesses := accesses + 1;
        end;
      end;
    end;
   end;

PROCEDURE showspace;

type                            { TYPE declarations }
  RegRec =
    record           { register pack Used in MSDos call }
      AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer;
    end;

var
  Tracks,                              { number of available Tracks }
  Drive,                               { Drive number }
  Bytes,                               { number of Bytes in one sector }
  Sectors              : Integer;      { number of total Sectors }
  TotalBytes           : real;
  Regs                 : RegRec;
  temp                 : line;


 begin
  Drive := 0;                             { Initialize Drive }
  Regs.AX := $3600;               { Get Disk free space }
  Regs.DX := Drive;               { Store Drive number }
  MSDos( Regs );                  { Call MSDos to get disk info }
  Tracks := Regs.BX;              { Get number of Tracks Used }
  Bytes := Regs.CX;                {  "    "    "  Bytes per sector }
  Sectors := Regs.AX;              {  "    "    "  Sectors per cluster }
  TotalBytes := (( Sectors * Bytes * 1.0 ) * Tracks);
  str(totalbytes:8:0, temp);
  if cts then lineout(cr + lf + temp + ' bytes available');
 end;

PROCEDURE dir(sectnum: byte);

    var loop, spaces : byte;
        howbig, sectmin : integer;
        any  : boolean;
        temp : line;

    begin
      any := false;
      sectmin := ksize shl 3;
      lineout_withpause(space);
      if sectsin then lineout_withpause('Section ' + sect[sectnum] + ':');
      if enddir > 0 then for loop := 1 to enddir do with filetab[loop] do begin
        howbig := (size + sectmin - 1) div sectmin;
        if cts and (public or (access = sysop) or (submit = usernum))
         and (sectnum = section) then begin
          str(howbig:4, temp);
          for spaces := length(title) to 13 do temp := ' ' + temp;
          stringout(title + temp + 'K ');
          if clockin then stringout(' ' + date + ' ');
          if not public then stringout('* Private * ');
          lineout_withpause(progdesc);
          if (access = sysop) or (submit = usernum) then begin
            str(accesses:4, temp);
            lineout_withpause('Accesses: ' + temp + '    From: ' + getname(submit));
          end;
          any := true;
        end;
      end;
      if cts and not any then lineout_withpause('No files found.');
    end;


  PROCEDURE directory;

    var sectnum : byte;

    begin
      linecnt := 0;
      stringout('Directory: ');
      sectnum := getsect;
      if sectnum > 0 then dir(sectnum)
        else for sectnum := 1 to numsects do dir(sectnum);
      showspace;
    end;

  PROCEDURE ldir;

    var
      tabloc : integer;

    begin
      tabloc := legaltab('Library directory: ');
      lineout(space);
      if tabloc > 0 then typefile(filedrive + filetab[tabloc].title + '/DIR', false);
    end;

  PROCEDURE killfile;

    var loop, tabloc: integer;

    begin
      tabloc := legaltab('Delete: ');
      if tabloc > 0 then begin
        if enddir > tabloc then for loop := tabloc + 1 to enddir do
          filetab[loop - 1] := filetab[loop];
        enddir := enddir - 1;
      end;
    end;

  PROCEDURE installfile;

    var filename : name;
        sectnum  : byte;

    begin
      if enddir < mostfiles then begin
        filename := getlegal;
        if filename <> '' then begin
          if exists(filedrive+filename) and (dirpos(filename) = 0) then begin
            repeat sectnum := getsect until (sectnum <> 0) or not cts;
            addfile(filename, sectnum, true);
            enddir := enddir + 1;
            lineout('File installed.');
          end;
        end;
      end;
    end;

  FUNCTION newname(tabloc: integer): name;

    var filename: name;

    begin
      newname := filetab[tabloc].title;
      stringout('New name? ');
      filename := getlegal;
      if (filename <> '') then begin
        if not exists(filedrive + filename) then begin
          assign(datafile, filedrive + filetab[tabloc].title);
          rename(datafile, filename);
          newname := filename;
          stringout('File renamed.');
        end
        else lineout('Name in use - cannot rename.');
      end;
    end;


  PROCEDURE editheader;

    var tabloc: integer;
        filename: name;
        innum: integer;
        sectstring: name;

    begin
      tabloc := legaltab('Edit: ');
      if tabloc > 0 then with filetab[tabloc] do begin
        repeat
          str(section:3, sectstring);
          lineout(space);
          lineout('1- Name    : ' + title);
          lineout('2- From    : ' + getname(submit));
          lineout('3- Section : ' + sectstring);
          lineout('4- Public? : ' + yn[public]);
          lineout('5- Desc.   : ' + progdesc);
          lineout(space);
          innum := getint(5, 0, 'Number of parameter to change? ');
          case innum of
            1: title    := newname(tabloc);
            2: submit   := getid('Name of submitter? ');
            3: repeat section := getsect until (section <> 0) or not cts;
            4: public   := not public;
            5: progdesc := getinput('Enter brief description of file? ', 41, echo);
          end;
        until (innum = 0) or not cts;
        assign(datafile, filedrive + title);
        reset(datafile);
        size := filesize(datafile);
        close(datafile);
      end else lineout('File not in directory.');
    end;

  PROCEDURE initfile;

    var
      loopvar: integer;
      temp: name;

    begin
      lineout('Initializing file system...');
      loopvar := 0;
      assign(filefile, 'FILES.BBS');
      {$I-} reset(filefile) {$I+};
      if IOresult = 0 then begin
        while not eof(filefile) do begin
          loopvar := loopvar + 1;
          read(filefile, filetab[loopvar]);
        end;
        close(filefile);
      end;
      enddir := loopvar;
      filesopen := true;
    end;

  PROCEDURE closefile;

      var
        loopvar: integer;

    begin
      rewrite(filefile);
      if enddir > 0 then
        for loopvar := 1 to enddir do write(filefile, filetab[loopvar]);
      close(filefile);
      filesopen := false;
    end;

  begin
    clearsc;
    initfile;
    if not expert then outfile(filemenu);
    repeat
      checktime;
      lineout(space);
      str(usehour:2,hh);
      str(usemin:2,mm);
      str(usesec:2,ss);
      tstr := hh + ':' + mm + ':' + ss;
      for junk := 1 to 8 do
        if tstr[junk] = ' ' then tstr[junk] := '0';
      if not expert then comch := getcap('File Section ' + tstr + ' (A,C,D,G,H,L,Q,S,T,U,X,Y,?) ? ')
        else comch := getcap('File Section ' + tstr + ' ? ');
      case comch of
       'D' : directory;
       'Y' : begin ymodem := true;  crcmode := true; transmitfile; end;
       'S' : begin ymodem := false; transmitfile; end;
       'T' : textdump;
       'H' : outfile(filehelp);
       'G' : disconnect;
       '?' : outfile(filemenu);
       'X' : expert := not expert;
       'L' : ldir;
       'U' : begin crcmode := true; newfile(true); end;
       'C' : begin crcmode := false; newfile(true); end;
       'A' : newfile(false);
       'K' : if access = sysop then killfile;
       'I' : if access = sysop then installfile;
       'E' : if access = sysop then editheader;
      end;
    until (comch = 'Q') or not cts;
    if cts then lineout('Closing file system...');
    closefile;
  end;