Category : Pascal Source Code
Archive   : TBBS.ZIP
Filename : FILESYS.INC

 
Output of file : FILESYS.INC contained in archive : TBBS.ZIP
(* ------------------------------------------------ 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;



  3 Responses to “Category : Pascal Source Code
Archive   : TBBS.ZIP
Filename : FILESYS.INC

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/