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 >
Wrap
Text File
|
1985-08-23
|
19KB
|
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;
əəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəə