home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / bbs / turbobbs / filesys.inc < prev    next >
Text File  |  1985-08-23  |  19KB  |  680 lines

  1. procedure filesys;
  2.  
  3.   const
  4.     soh = 1;
  5.     eot = 4;
  6.     ack = 6;
  7.     nak = $15;
  8.     can = $18;
  9.     C = $43;
  10.  
  11.   type
  12.     filerec = record
  13.                title: name;
  14.                submit: integer;
  15.                date: name;
  16.                size: integer;
  17.                accesses: integer;
  18.                ASCII: boolean;
  19.                section: byte;
  20.                public: boolean;
  21.              end;
  22.     channel = array[0..127] of byte;
  23.  
  24.   var
  25.     filefile: file of filerec;
  26.     filetab: array[0..40] of filerec;
  27.     filebuff: array [0..16] of channel;
  28.     datafile: file;
  29.     chksum: byte;
  30.     CRC: integer;
  31.     crcmode: boolean;
  32.     enddir: integer;
  33.     comch: char;
  34.  
  35.   procedure xmit(x:byte);
  36.  
  37.     begin
  38.       xmitchar(chr(x));
  39.     end;
  40.  
  41.   function inbyte: byte;
  42.  
  43.     var temp: char;
  44.  
  45.     begin
  46.       repeat until inready or not cts;
  47.       if keypressed then read(kbd, temp) else temp := recvchar;
  48.       inbyte := ord(temp);
  49.     end;
  50.  
  51.   procedure calcCRC(data:byte);
  52.  
  53.     var
  54.       carry: boolean;
  55.       i: byte;
  56.  
  57.     begin
  58.       chksum := lo(chksum + data);
  59.       for i := 0 to 7 do begin
  60.         carry := (crc and $8000) <> 0;
  61.         crc := crc shl 1;
  62.         if (data and $80) <> 0 then crc := crc or $0001;
  63.         if carry then crc := crc xor $1021;
  64.         data := lo(data shl 1);
  65.       end;
  66.     end;
  67.  
  68.   procedure sendcalc(ch : byte);
  69.  
  70.     begin
  71.       xmit(ch);
  72.       calcCRC(ch);
  73.     end;
  74.  
  75.   procedure acknak(var inch: byte; time: integer);
  76.  
  77.     var loop, loopend: integer;
  78.  
  79.     begin
  80.       loopend := 100 * time;
  81.       loop := 0;
  82.       inch := 0;
  83.       repeat
  84.         delay(10);
  85.         if inready then inch := inbyte;
  86.         loop :=loop + 1;
  87.       until (inch in [ack, nak, can, C]) or (loop >= loopend) or not cts;
  88.     end;
  89.  
  90.   function timedin: boolean;
  91.  
  92.     var times: integer;
  93.  
  94.     begin
  95.       times := 0;
  96.       while (times < 500) and not inready do begin
  97.         times := times + 1;
  98.         delay(2);
  99.       end;
  100.       timedin := inready and cts;
  101.     end;
  102.  
  103.   function acknakout(ch : byte): boolean;
  104.  
  105.     var  times, loops: integer;
  106.  
  107.     begin
  108.       times := 0;
  109.       repeat
  110.         loops := 0;
  111.         xmit(ch);
  112.         while (loops < 10) and not timedin do loops := loops + 1;
  113.         times := times + 1;
  114.       until inready or (times > 9) or not cts;
  115.       acknakout := inready and cts;
  116.     end;
  117.  
  118.   procedure download(var successful: boolean);
  119.  
  120.     var inch: byte;
  121.         loop, blocknum: byte;
  122.         period, tries: integer;
  123.         done: boolean;
  124.  
  125.     begin
  126.       reset(datafile);
  127.       blockread(datafile, filebuff[0], 1);
  128.       done := false;
  129.       tries := 0;
  130.       blocknum := 1;
  131.       crcmode := false;
  132.       repeat
  133.         acknak(inch, 60);
  134.         if inch = 0 then inch := can;
  135.         if inch = C then begin
  136.           crcmode := true;
  137.           writeln('CRC mode requested');
  138.         end;
  139.         if inch = ack then begin
  140.           if eof(datafile) then done := true else begin
  141.             write(cr + 'Sent #', blocknum:3);
  142.             blockread(datafile, filebuff[0], 1);
  143.             blocknum := lo(blocknum + 1);
  144.             tries := 0;
  145.           end;
  146.         end
  147.         else tries := tries + 1;
  148.         if (inch <> can) and cts and not done then begin
  149.           xmit(soh);
  150.           xmit(blocknum);
  151.           xmit(255-blocknum);
  152.           chksum := 0;
  153.           crc := 0;
  154.           for loop := 0 to 127 do sendcalc(filebuff[0][loop]);
  155.           calcCRC(0);
  156.           calcCRC(0);
  157.           if crcmode then begin xmit(hi(crc)); xmit(lo(crc)); end
  158.             else xmit(chksum);
  159.         end;
  160.         if tries = 5 then crcmode := not crcmode;
  161.       until (inch = can) or done or (tries= 10) or not cts;
  162.       successful := done;
  163.       tries := 0;
  164.       if successful and cts then repeat
  165.         xmit(eot);
  166.         acknak(inch, 10);
  167.         tries := tries + 1;
  168.       until (inch=ack) or (tries > 10) or not cts;
  169.       if cts and (inch <> can) and not successful then xmit(can);
  170.       close(datafile);
  171.     end;
  172.  
  173.   function recchar(var error: boolean): byte;
  174.  
  175.     var temp: byte;
  176.  
  177.     begin
  178.       temp := 0;
  179.       if not cts then error := true;
  180.       if not error then begin
  181.         if not timedin then error := true
  182.         else begin
  183.           temp := inbyte;
  184.           calcCRC(temp);
  185.           recchar := temp;
  186.         end;
  187.       end;
  188.     end;
  189.  
  190.   procedure clearline;
  191.  
  192.     var junk: byte;
  193.  
  194.     begin
  195.       repeat junk := port[iodata] until not timedin;
  196.     end;
  197.  
  198. {$I-}
  199.   procedure upload(var successful: boolean);
  200.  
  201.     var
  202.       blocknum, tries, byteloc : integer;
  203.       comp, locblock, crc2     : integer;
  204.       fatal, error, done       : boolean;
  205.       opening, inch, locrc     : byte;
  206.       hicrc, csum2, mode       : byte;
  207.  
  208.     begin
  209.       lineout('Beginning XMODEM protocol transfer: CTRL-X aborts');
  210.       tries := 0;
  211.       done := false;
  212.       opening := 0;
  213.       locblock := 1;
  214.       rewrite(datafile);
  215.       fatal := ioresult > 0;
  216.       if crcmode then mode := C else mode := nak;
  217.       if cts and not fatal then fatal := not acknakout(mode);
  218.       while cts and not (done or fatal) do begin
  219.         tries := tries + 1;
  220.         error := false;
  221.         opening := recchar(error);
  222.         if opening = can then fatal := true;
  223.         if opening = eot then done := true;
  224.         if (opening <> eot) and (opening <> soh) and not fatal
  225.           then error := true;
  226.         if cts and not (error or fatal or done) then begin
  227.           blocknum := recchar(error);
  228.           comp := recchar(error);
  229.           if lo(comp + blocknum + opening) <> 0 then error := true;
  230.           byteloc := 0;
  231.           crc := 0;
  232.           chksum := 0;
  233.           while (byteloc < 128) and not (error or fatal) do begin
  234.             filebuff[0][byteloc] := recchar(error);
  235.             byteloc := byteloc + 1;
  236.           end;
  237.           if cts and not (error or fatal) then begin
  238.             calcCRC(0);
  239.             calcCRC(0);
  240.             crc2 := crc;
  241.             csum2 := chksum;
  242.             hicrc := recchar(error);
  243.             if crcmode then begin
  244.               locrc := recchar(error);
  245.               if (lo(crc2) <> locrc) or (hi(crc2) <> hicrc) then error := true;
  246.             end else if csum2 <> hicrc then error := true;
  247.             if (locblock<>blocknum)
  248.               and (locblock<>lo(blocknum+1))
  249.               and not error
  250.               then fatal := true;
  251.             if (locblock=blocknum) and not (error or fatal) then begin
  252.               blockwrite(datafile, filebuff[0], 1);
  253.               write(cr + ' Received #', blocknum:3);
  254.               if IOresult <> 0 then fatal := true;
  255.               tries := 0;
  256.               locblock := lo(locblock + 1);
  257.             end;
  258.           end;
  259.         end;
  260.         if not (fatal or error) then flush else clearline;
  261.         if done or not (error or fatal) then fatal := not acknakout(ack);
  262.         if error and not fatal then begin
  263.           fatal := not acknakout(nak);
  264.           if tries > 6 then crcmode := not crcmode;
  265.         end;
  266.       end;
  267.       if fatal then error := not acknakout(can);
  268.       if done then error := not acknakout(ack);
  269.       close(datafile);
  270.       successful := (IOresult = 0) and done and not fatal;
  271.       if not successful then erase(datafile);
  272.     end;
  273.  
  274.   procedure storebuff(var buffernum: byte; var paused, aborted: boolean);
  275.  
  276.     var loop: byte;
  277.  
  278.     begin
  279.       loop := 0;
  280.       while (loop < buffernum) and not aborted do begin
  281.         blockwrite(datafile, filebuff[loop], 1);
  282.         if IOresult > 0 then aborted := true;
  283.         loop := loop + 1;
  284.       end;
  285.       if buffernum in [1..16] then filebuff[0] := filebuff[buffernum];
  286.       buffernum := 0;
  287.       repeat xmit(17) until timedin;
  288.       paused := false;
  289.     end;
  290.  
  291.   procedure textcap(var successful: boolean);
  292.  
  293.     var
  294.       buffernum, where, loop  : byte;
  295.       cc, cz, paused          : boolean;
  296.       withecho, done, aborted : boolean;
  297.       temp                    : byte;
  298.  
  299.     begin
  300.       withecho := (getcap('Do you want your text echoed (Y/N) ? ') = 'Y');
  301.       lineout('Beginning text capture: two CTRL-Cs abort, two CTRL-Zs end.');
  302.       cc := false;
  303.       cz := false;
  304.       done := false;
  305.       paused := false;
  306.       buffernum := 0;
  307.       where := 0;
  308.       rewrite(datafile);
  309.       aborted := (IOresult > 0);
  310.       while cts and not (done or aborted) do begin
  311.         if paused then
  312.           if not timedin then storebuff(buffernum, paused, aborted);
  313.         temp := inbyte;
  314.         if not cts then aborted := true;
  315.         if withecho and outready then xmit(temp);
  316.         if temp = 3 then begin if cc then aborted := true else cc := true; end
  317.           else cc := false;
  318.         if temp = 26 then begin if cz then done := true else cz := true; end
  319.           else cz := false;
  320.         filebuff[buffernum][where] := temp;
  321.         where := where + 1;
  322.         if where > 127 then begin
  323.           where := 0;
  324.           buffernum := buffernum + 1;
  325.         end;
  326.         if buffernum > 14 then begin
  327.           xmit(19);
  328.           paused := true;
  329.         end;
  330.         if buffernum > 16 then aborted := true;
  331.       end;
  332.       if done and cts and not aborted then begin
  333.         buffernum := buffernum + 1;
  334.         storebuff(buffernum, paused, aborted);
  335.       end;
  336.       close(datafile);
  337.       if aborted and (IOresult = 0) then erase(datafile);
  338.     successful := done and (IOresult=0) and not aborted;
  339.     end;
  340. {$I+}
  341.  
  342.   function exists(filename: name): boolean;
  343.  
  344.     var found: boolean;
  345.  
  346.     begin
  347.       assign(datafile, filename);
  348.       {$I-} reset(datafile) {$I+};
  349.       found := (IOresult = 0);
  350.       if found then close(datafile);
  351.       exists := found;
  352.     end;
  353.  
  354.   function alpha(filename: name): boolean;
  355.  
  356.     var strpos: integer;
  357.         okay:   boolean;
  358.  
  359.     begin
  360.       alpha := true;
  361.       if length(filename) > 0 then
  362.         for strpos := 1 to length(filename) do
  363.           if not (filename[strpos] in ['.', '0'..'9', 'A'..'Z'])
  364.             then alpha := false;
  365.     end;
  366.  
  367.   function getlegal: name;
  368.  
  369.     var filename:  name;
  370.         dotpos: integer;
  371.  
  372.     begin
  373.       repeat
  374.         filename := allcaps(getinput('Enter name of file ? ', 12, echo));
  375.         dotpos := pos('.', filename);
  376.       until ((dotpos < 9) and (dotpos > 1)
  377.        and (not((dotpos = 0) and (length(filename) > 8)))
  378.        and (not((dotpos > 0) and (length(filename) > dotpos + 3)))
  379.        and alpha(filename))
  380.        or (filename = '');
  381.       getlegal := filename;
  382.     end;
  383.  
  384.   function dirpos(filename: name): integer;
  385.  
  386.     var loopvar: integer;
  387.  
  388.     begin
  389.       dirpos := 0;
  390.       loopvar := 0;
  391.       repeat
  392.         loopvar := loopvar + 1;
  393.       until (filetab[loopvar].title = filename) or (loopvar >= enddir);
  394.     if filetab[loopvar].title = filename then dirpos := loopvar;
  395.     end;
  396.  
  397.   function getsect: byte;
  398.  
  399.     var temp: char;
  400.  
  401.     begin
  402.       if sectsin then repeat
  403.         temp := getinput('Which section (0 for all, ? for list) ? ', 1, echo);
  404.         if temp = '?' then listsections;
  405.         if temp in ['0'..'9'] then getsect := ord(temp) - ord('0');
  406.       until (temp in ['0'..'9']) or not cts
  407.       else getsect := 1;
  408.     end;
  409.  
  410.   procedure addfile(filename: name; sectnum: byte; xmodem: boolean);
  411.  
  412.     begin
  413.       with filetab[enddir + 1] do begin
  414.         title := filename;
  415.         submit := usernum;
  416.         if clockin then date := timeon;
  417.         assign(datafile, 'B:' + filename);
  418.         reset(datafile);
  419.         size := filesize(datafile);
  420.         close(datafile);
  421.         accesses := 0;
  422.         ASCII := not xmodem;
  423.         section := sectnum;
  424.         public := false;
  425.       end;
  426.     end;
  427.  
  428.   procedure newfile(xmodem: boolean);
  429.  
  430.     var
  431.       filename: name;
  432.       successful: boolean;
  433.       sectnum: byte;
  434.  
  435.     begin
  436.       clearsc;
  437.       if enddir >= 40 then lineout('No file space available.')
  438.       else begin
  439.         stringout('Upload: ');
  440.         filename := getlegal;
  441.         if filename <> '' then begin
  442.           if exists('B:' + filename) then lineout('File name already in use.')
  443.           else begin
  444.             repeat sectnum := getsect until (sectnum in [1..9]) or not cts;
  445.             assign(datafile, 'B:' + filename);
  446.             if cts then begin
  447.               if xmodem then upload(successful)
  448.                 else textcap(successful);
  449.               if successful then addfile(filename, sectnum, xmodem);
  450.               clearline;
  451.               if successful then enddir := enddir + 1
  452.                 else lineout('Fatal transfer error or disk full...');
  453.             end;
  454.           end;
  455.         end;
  456.       end;
  457.     end;
  458.  
  459.   function legaltab(prompt: line): integer;
  460.  
  461.     var filename: name;
  462.         tabloc:   integer;
  463.  
  464.     begin
  465.       tabloc := 0;
  466.       clearsc;
  467.       stringout(prompt);
  468.       filename := getlegal;
  469.       if filename <> '' then begin
  470.         tabloc := dirpos(filename);
  471.         if tabloc <> 0 then
  472.           if not (filetab[tabloc].public or (access > 2)) then tabloc := 0;
  473.         if tabloc <> 0 then assign(datafile, 'B:' + filename)
  474.           else if filename <> '' then lineout('No such file available.');
  475.       end;
  476.       legaltab := tabloc;
  477.     end;
  478.  
  479.   procedure transmitfile;
  480.  
  481.     var
  482.       successful: boolean;
  483.       tabloc: integer;
  484.  
  485.     begin
  486.       tabloc := legaltab('Download: ');
  487.       if tabloc > 0 then begin
  488.         lineout('Ready for XMODEM protocol transfer: CTRL-X aborts.');
  489.         download(successful);
  490.         if successful then with filetab[tabloc] do
  491.           accesses := accesses + 1
  492.         else lineout('Transfer failed.');
  493.       end;
  494.     end;
  495.  
  496.   procedure textdump;
  497.  
  498.     var
  499.       tabloc, counter: integer;
  500.       letter : char;
  501.       cz : byte;
  502.  
  503.     begin
  504.       tabloc := legaltab('ASCII text dump: ');
  505.       if tabloc > 0 then begin
  506.         lineout('Press a key to begin: 2 * CTRL-Z = end-of file marker.');
  507.         letter := charin(noecho);
  508.         reset(datafile);
  509.         cz := 0;
  510.         while cts and (cz < 2) and not (eof(datafile) or cancelled) do begin
  511.           blockread(datafile, filebuff[0], 1);
  512.           counter := 0;
  513.           while cts and (cz < 2) and (counter < 128) and not cancelled do begin
  514.             letter := chr(filebuff[0][counter]);
  515.             if letter = #26 then cz := cz + 1 else cz := 0;
  516.             sendout(letter);
  517.             counter := counter + 1;
  518.           end;
  519.         end;
  520.         if cz < 2 then for counter := cz to 2 do sendout(#26);
  521.         if not cancelled then with filetab[tabloc] do
  522.           accesses := accesses + 1
  523.       end;
  524.     end;
  525.  
  526.   procedure directory;
  527.  
  528.     var loop, spaces, sectnum : byte;
  529.         any  : boolean;
  530.         temp : line;
  531.  
  532.     begin
  533.       any := false;
  534.       stringout('Directory: ');
  535.       sectnum := getsect;
  536.       lineout(space);
  537.       if enddir > 0 then
  538.         for loop := 1 to enddir do
  539.           with filetab[loop] do
  540.             if cts and (public or (access = 5))
  541.               and ((sectnum = 0) or (sectnum = section)) then begin
  542.               str(size:5, temp);
  543.               for spaces := length(title) to 16 do temp := ' ' + temp;
  544.               stringout(title + temp);
  545.               if clockin then stringout('   ' + date);
  546.               if sectsin then stringout('   ' + sect[section]);
  547.               lineout(space);
  548.               if access = 5 then begin
  549.                 str(accesses:4, temp);
  550.                 lineout('Accesses: ' + temp + ' From: ' + getname(submit));
  551.               end;
  552.               any := true;
  553.             end;
  554.        if not any then lineout('No files found.');
  555.      end;
  556.  
  557.   procedure killfile;
  558.  
  559.     var loop, tabloc: integer;
  560.  
  561.     begin
  562.       tabloc := legaltab('Delete: ');
  563.       if tabloc > 0 then begin
  564.         erase(datafile);
  565.         if enddir > tabloc then for loop := tabloc + 1 to enddir do
  566.           filetab[loop - 1] := filetab[loop];
  567.         enddir := enddir - 1;
  568.       end;
  569.     end;
  570.  
  571.   procedure installfile;
  572.  
  573.     var filename : name;
  574.         sectnum  : byte;
  575.  
  576.     begin
  577.       if enddir < 40 then begin
  578.         filename := getlegal;
  579.         if filename <> '' then
  580.           if exists('B:' + filename) and (dirpos(filename) = 0) then begin
  581.             repeat sectnum := getsect until (sectnum in [1..9]) or not cts;
  582.             addfile(filename, sectnum, true);
  583.             enddir := enddir + 1;
  584.             lineout('File installed.');
  585.           end;
  586.       end;
  587.     end;
  588.  
  589.   procedure release;
  590.  
  591.     var tabloc : integer;
  592.  
  593.     begin
  594.       tabloc := legaltab('Release: ');
  595.       if tabloc <> 0 then filetab[tabloc].public := true;
  596.       lineout('File released.');
  597.     end;
  598.  
  599.   procedure initfile;
  600.  
  601.     var
  602.       loopvar: integer;
  603.       temp: name;
  604.  
  605.     begin
  606.       lineout('Initializing file system...');
  607.       assign(filefile, 'FILES.BBS');
  608.       reset(filefile);
  609.       loopvar := 0;
  610.       while not eof(filefile) do begin
  611.         loopvar := loopvar + 1;
  612.         read(filefile, filetab[loopvar]);
  613.       end;
  614.       enddir := loopvar;
  615.       str(enddir:2, temp);
  616.       lineout(temp + ' files in system.');
  617.       close(filefile);
  618.       filesopen := true;
  619.     end;
  620.  
  621.   procedure closefile;
  622.  
  623.     var loopvar: integer;
  624.  
  625.     begin
  626.       rewrite(filefile);
  627.       if enddir > 0 then
  628.         for loopvar := 1 to enddir do write(filefile, filetab[loopvar]);
  629.       close(filefile);
  630.       filesopen := false;
  631.     end;
  632.  
  633.   procedure filemenu;
  634.  
  635.     begin
  636.       if cts then begin
  637.         lineout('Menu: ' + cr + lf);
  638.         lineout('  [D]irectory');
  639.         lineout('  [Q]uit to BBS');
  640.         if access = 5 then begin
  641.           lineout('  [R]elease file to public');
  642.           lineout('  [I]nstall file on disk');
  643.           lineout('  [K]ill file');
  644.         end;
  645.         lineout('XMODEM:');
  646.         lineout('  [S]end file to your system;');
  647.         lineout('  [U]pload a file to this system (CRC mode);');
  648.         lineout('  [C]hecksum upload.');
  649.         lineout('Verbatim dump (no error checks or control-masking):');
  650.         lineout('  [V]erbatim dump a file to this system;');
  651.         lineout('  [T]ype a file from the system.');
  652.       end;
  653.     end;
  654.  
  655.   begin
  656.     initfile;
  657.     clearsc;
  658.     stringout('File subsytem: ');
  659.     if not expert then filemenu;
  660.     repeat
  661.       lineout(space);
  662.       comch := getcap('Files command (or ? for menu) ? ');
  663.       case comch of
  664.         'D' : directory;
  665.         'S' : transmitfile;
  666.         'U' : if access > 1 then begin crcmode := true; newfile(true); end;
  667.         'C' : if access > 1 then begin crcmode := false; newfile(true); end;
  668.         'V' : if access > 1 then newfile(false);
  669.         'T' : textdump;
  670.         'K' : if access = 5 then killfile;
  671.         'I' : if access = 5 then installfile;
  672.         'R' : if access = 5 then release;
  673.         '?' : filemenu;
  674.       end;
  675.     until (comch = 'Q') or not cts;
  676.     if cts then lineout('Closing file system...');
  677.     closefile;
  678.   end;
  679.  
  680. əəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəə