GEMini Atari/GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso/files/bbs/turbobbs/filesys.inc

Text File | 1985-08-24 | 18.9 KB | 680 lines

procedure filesys;

  const
    soh = 1;
    eot = 4;
    ack = 6;
    nak = $15;
    can = $18;
    C = $43;

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

  var
    filefile: file of filerec;
    filetab: array[0..40] of filerec;
    filebuff: array [0..16] of channel;
    datafile: file;
    chksum: byte;
    CRC: integer;
    crcmode: boolean;
    enddir: integer;
    comch: char;

  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 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 timedin: boolean;

    var times: integer;

    begin
      times := 0;
      while (times < 500) and not inready do begin
        times := times + 1;
        delay(2);
      end;
      timedin := inready and 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, blocknum: byte;
        period, tries: integer;
        done: boolean;

    begin
      reset(datafile);
      blockread(datafile, filebuff[0], 1);
      done := false;
      tries := 0;
      blocknum := 1;
      crcmode := false;
      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:3);
            blockread(datafile, filebuff[0], 1);
            blocknum := lo(blocknum + 1);
            tries := 0;
          end;
        end
        else tries := tries + 1;
        if (inch <> can) and cts and not done then begin
          xmit(soh);
          xmit(blocknum);
          xmit(255-blocknum);
          chksum := 0;
          crc := 0;
          for loop := 0 to 127 do sendcalc(filebuff[0][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;
      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
      repeat junk := port[iodata] until not timedin;
    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 transfer: CTRL-X aborts');
      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 (locblock<>blocknum)
              and (locblock<>lo(blocknum+1))
              and not error
              then fatal := true;
            if (locblock=blocknum) and not (error or fatal) then begin
              blockwrite(datafile, filebuff[0], 1);
              write(cr + ' Received #', blocknum:3);
              if IOresult <> 0 then fatal := true;
              tries := 0;
              locblock := lo(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 error := not acknakout(can);
      if done then error := not acknakout(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;

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

  function getlegal: name;

    var filename:  name;
        dotpos: integer;

    begin
      repeat
        filename := allcaps(getinput('Enter name of file ? ', 12, echo));
        dotpos := pos('.', filename);
      until ((dotpos < 9) 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;
    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: char;

    begin
      if sectsin then repeat
        temp := getinput('Which section (0 for all, ? for list) ? ', 1, echo);
        if temp = '?' then listsections;
        if temp in ['0'..'9'] then getsect := ord(temp) - ord('0');
      until (temp in ['0'..'9']) 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;
        if clockin then date := timeon;
        assign(datafile, 'B:' + 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 enddir >= 40 then lineout('No file space available.')
      else begin
        stringout('Upload: ');
        filename := getlegal;
        if filename <> '' then begin
          if exists('B:' + filename) then lineout('File name already in use.')
          else begin
            repeat sectnum := getsect until (sectnum in [1..9]) or not cts;
            assign(datafile, 'B:' + 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;

  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 > 2)) then tabloc := 0;
        if tabloc <> 0 then assign(datafile, 'B:' + filename)
          else if filename <> '' then lineout('No such file available.');
      end;
      legaltab := tabloc;
    end;

  procedure transmitfile;

    var
      successful: boolean;
      tabloc: integer;

    begin
      tabloc := legaltab('Download: ');
      if tabloc > 0 then begin
        lineout('Ready for XMODEM protocol transfer: CTRL-X aborts.');
        download(successful);
        if successful then with filetab[tabloc] do
          accesses := accesses + 1
        else lineout('Transfer failed.');
      end;
    end;

  procedure textdump;

    var
      tabloc, counter: integer;
      letter : char;
      cz : byte;

    begin
      tabloc := legaltab('ASCII text dump: ');
      if tabloc > 0 then begin
        lineout('Press a key to begin: 2 * CTRL-Z = end-of file marker.');
        letter := charin(noecho);
        reset(datafile);
        cz := 0;
        while cts and (cz < 2) and not (eof(datafile) or cancelled) do begin
          blockread(datafile, filebuff[0], 1);
          counter := 0;
          while cts and (cz < 2) and (counter < 128) and not cancelled do begin
            letter := chr(filebuff[0][counter]);
            if letter = #26 then cz := cz + 1 else cz := 0;
            sendout(letter);
            counter := counter + 1;
          end;
        end;
        if cz < 2 then for counter := cz to 2 do sendout(#26);
        if not cancelled then with filetab[tabloc] do
          accesses := accesses + 1
      end;
    end;

  procedure directory;

    var loop, spaces, sectnum : byte;
        any  : boolean;
        temp : line;

    begin
      any := false;
      stringout('Directory: ');
      sectnum := getsect;
      lineout(space);
      if enddir > 0 then
        for loop := 1 to enddir do
          with filetab[loop] do
            if cts and (public or (access = 5))
              and ((sectnum = 0) or (sectnum = section)) then begin
              str(size:5, temp);
              for spaces := length(title) to 16 do temp := ' ' + temp;
              stringout(title + temp);
              if clockin then stringout('   ' + date);
              if sectsin then stringout('   ' + sect[section]);
              lineout(space);
              if access = 5 then begin
                str(accesses:4, temp);
                lineout('Accesses: ' + temp + ' From: ' + getname(submit));
              end;
              any := true;
            end;
       if not any then lineout('No files found.');
     end;

  procedure killfile;

    var loop, tabloc: integer;

    begin
      tabloc := legaltab('Delete: ');
      if tabloc > 0 then begin
        erase(datafile);
        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 < 40 then begin
        filename := getlegal;
        if filename <> '' then
          if exists('B:' + filename) and (dirpos(filename) = 0) then begin
            repeat sectnum := getsect until (sectnum in [1..9]) or not cts;
            addfile(filename, sectnum, true);
            enddir := enddir + 1;
            lineout('File installed.');
          end;
      end;
    end;

  procedure release;

    var tabloc : integer;

    begin
      tabloc := legaltab('Release: ');
      if tabloc <> 0 then filetab[tabloc].public := true;
      lineout('File released.');
    end;

  procedure initfile;

    var
      loopvar: integer;
      temp: name;

    begin
      lineout('Initializing file system...');
      assign(filefile, 'FILES.BBS');
      reset(filefile);
      loopvar := 0;
      while not eof(filefile) do begin
        loopvar := loopvar + 1;
        read(filefile, filetab[loopvar]);
      end;
      enddir := loopvar;
      str(enddir:2, temp);
      lineout(temp + ' files in system.');
      close(filefile);
      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;

  procedure filemenu;

    begin
      if cts then begin
        lineout('Menu: ' + cr + lf);
        lineout('  [D]irectory');
        lineout('  [Q]uit to BBS');
        if access = 5 then begin
          lineout('  [R]elease file to public');
          lineout('  [I]nstall file on disk');
          lineout('  [K]ill file');
        end;
        lineout('XMODEM:');
        lineout('  [S]end file to your system;');
        lineout('  [U]pload a file to this system (CRC mode);');
        lineout('  [C]hecksum upload.');
        lineout('Verbatim dump (no error checks or control-masking):');
        lineout('  [V]erbatim dump a file to this system;');
        lineout('  [T]ype a file from the system.');
      end;
    end;

  begin
    initfile;
    clearsc;
    stringout('File subsytem: ');
    if not expert then filemenu;
    repeat
      lineout(space);
      comch := getcap('Files command (or ? for menu) ? ');
      case comch of
        'D' : directory;
        'S' : transmitfile;
        'U' : if access > 1 then begin crcmode := true; newfile(true); end;
        'C' : if access > 1 then begin crcmode := false; newfile(true); end;
        'V' : if access > 1 then newfile(false);
        'T' : textdump;
        'K' : if access = 5 then killfile;
        'I' : if access = 5 then installfile;
        'R' : if access = 5 then release;
        '?' : filemenu;
      end;
    until (comch = 'Q') or not cts;
    if cts then lineout('Closing file system...');
    closefile;
  end;

əəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəə