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

 
Output of file : MAILSYS.INC contained in archive : TBBS.ZIP
(* --------------------------------------- MAILSYS.INC -------------------------------------------- *)

const
numsects = 10;
maxlength = 24;
maxlenstr = '24';

type
messages = record
number: integer;
sender: integer;
recver: integer;
subject: name;
date: name;
private: boolean;
section: byte;
repto: integer;
reply: integer;
recved: boolean;
end;
sectname = array[1..numsects] of string[20];
messtext = array[1..maxlength] of line;

const
sect : sectname = (' 1: General',
' 2: IBM PC',
' 3: Turbo Pascal',
' 4: DOS',
' 5: Basic',
' 6: Communications',
' 7: Utilities',
' 8: New BBSs',
' 9: TurboBBS',
'10: Games');
maxmess = 60;

var
messagefile: file of messages;
count: integer;
messtable: array[1..maxmess] of messages;
preformat: boolean;

function namemess(number: integer): name;

var
filename: name;

begin
str((10000 + number):6, filename);
namemess := messdrive + 'MESS' + copy(filename, 3, 4) + '.MSG';
end;

procedure kill(x: integer);

var
victim: text;
junk: byte;

begin
write(x,' ',namemess(x));
assign(victim, namemess(x));
{$I-} erase(victim) {$I+};
junk := IOresult;
end;

function secure(tabloc: byte): boolean;

begin
with messtable[tabloc] do
secure := ((usernum <> sender)
and (usernum <> recver)
and (access < sysop))
or (usernum = 0);
end;

procedure listsections;

var
loopvar : integer;
temp : line;

begin
if cts then begin
clearsc;
lineout('Sections:' + cr + lf);
for loopvar := 1 to numsects do begin
lineout(sect[loopvar]);
end;
end;
end;

procedure status;

var
temp: line;

begin
if cts then begin
lineout(cr + lf + 'Caller: ' + caller);
str(access:1, temp);
lineout('Access level: ' + temp);
str(count:2, temp);
lineout('System has ' + temp + ' messages;');
str(nextmess:4, temp);
lineout('Next message is: ' + temp);
connecttime;
str(usercnt:8:0, temp);
lineout('Caller number' + temp);
end;
end;

procedure initmess;

begin
if cts then lineout(cr + lf + 'Initializing message system...');
count := 0;
nextmess := 1;
assign(messagefile, 'MESSAGES.BBS');
{$I-} reset(messagefile) {$I+};
if IOresult = 0 then begin
while (count < maxmess) and not eof(messagefile) do begin
count := count + 1;
read(messagefile, messtable[count]);
end;
close(messagefile);
if count > 0 then nextmess := messtable[count].number + 1;
end;
messopen := true;
status;
end;

function findmessage(x: integer): byte;

var
loop: byte;

begin
loop := 0;
findmessage := 0;
if count > 0 then begin
repeat
loop := loop + 1;
until (loop >= count) or (messtable[loop].number >= x);
if messtable[loop].number = x
then findmessage := loop
else findmessage := 0;
end;
end;

function getname(usernum: integer): person;

var
tempid: sysid;

begin
seek(idfile, usernum-1);
read(idfile, tempid);
getname := tempid.user;
end;

procedure header(tabloc: byte);

var
temp: line;

begin
if cts then with messtable[tabloc] do begin
str(number:4, temp);
stringout(cr + lf);
if private then stringout('Private ');
stringout('Message #' + temp);
temp := getname(sender);
stringout(' is from: ' + temp);
if recver > 0 then temp := getname(recver) else temp := 'ALL';
if recved then temp := temp + ' (Rec''d)';
lineout(' to: ' + temp);
stringout('Subj: ' + subject);
if clockin then stringout(' Time: ' + date);
if sectsin then stringout(' Section ' + sect[section]);
lineout(space);
end;
end;

procedure destroy(tabloc: byte);

var
loop: byte;

begin
if tabloc > 0 then begin
kill(messtable[tabloc].number);
for loop := tabloc+1 to count do
messtable[loop-1] := messtable[loop];
count := count - 1;
lineout('Message deleted.');
end;
end;

procedure readfile(tabloc: byte);

begin
if cts then begin
outfile(namemess(messtable[tabloc].number));
lineout(space);
if (messtable[tabloc].recver = usernum) and (usernum > 0)
then messtable[tabloc].recved := true;
if cts and (tabloc > 1) and not secure(tabloc) then begin
if getcap('Delete (Y/N)? ') = 'Y' then destroy(tabloc);
end;
end;
end;

procedure readmess(number: integer);

var tabloc: byte;

begin
tabloc := findmessage(number);
if tabloc = 0 then lineout('Message not found.')
else if (secure(tabloc) and messtable[tabloc].private)
then lineout('Private message.')
else begin
header(tabloc);
readfile(tabloc);
end;
end;

procedure delmessage(x: integer);

var
tabloc: byte;

begin;
tabloc := findmessage(x);
if cts then begin
if tabloc > 0 then begin
if not secure(tabloc) then begin
header(tabloc);
if getcap('Are you sure (Y/N)? ') = 'Y' then destroy(tabloc);
end
else lineout('You can''t delete that message.');
end
else lineout('Message not found.');
end;
end;

function getid(prompt: line): integer;

var
temp: person;

begin
temp := allcaps(getinput(prompt, 28, echo));
if temp = '' then getid := 0 else getid := findid(temp);
end;

procedure deletex;

begin
if access < reg then lineout('You can not delete a message yet. Use [A]pply command.')
else begin
if cts then delmessage(getint(nextmess - 1, 0, 'Delete: which number? '));
end;
end;

procedure quickscan;

var
loop: byte;
first: integer;

begin
if cts then begin
first := getint(nextmess - 1, lastmess + 1, 'Start scan at which number (* for new)? ');
if first > 0 then begin
clearsc;
for loop := 1 to count do
if (messtable[loop].number >= first)
and not (secure(loop) and messtable[loop].private)
and cts and not cancelled
then header(loop);
end;
end;
end;

procedure readind;

var
messnum: integer;
tabloc : byte;

begin
repeat
messnum := getint(nextmess - 1, 0, 'Read which number (enter 0 to quit)? ');
if messnum > 0 then readmess(messnum);
until (messnum <= 0) or not cts;
end;

procedure messagesearch(first:byte; fromnum, tonum:integer; sectnum:byte);

var
loop: byte;
inch: char;
oldnum: integer;
matched: boolean;

begin
matched := false;
inch := null;
loop := first;
if loop = 0 then loop := 1;
while cts and (loop <= count) and (inch <> 'Q') and (count <> 0) do begin
oldnum := messtable[loop].number;
if ((fromnum = 0) or (fromnum = messtable[loop].sender))
and ((tonum = 0) or (tonum = messtable[loop].recver))
and ((sectnum = 0) or (sectnum = messtable[loop].section))
and not (secure(loop) and messtable[loop].private)
then begin
matched := true;
cancelled := false;
header(loop);
inch := getcap('Read (/N/Quit)? ');
if (inch = 'Y') or (inch = cr) then readfile(loop);
end;
if messtable[loop].number = oldnum then loop := loop + 1;
end;
if cts and not matched then lineout('No messages found.');
end;

function findfirst(startmess: integer): byte;

var loop : byte;

begin
loop := 0;
if count > 0 then repeat
loop := loop + 1;
until (messtable[loop].number >= startmess) or (loop = count);
findfirst := loop;
end;

function getfirst: byte;

var
startmess : integer;

begin
repeat
startmess := getint(nextmess - 1, lastmess + 1, 'Start at which message (? for stats, * for new)? ');
if startmess = -1 then status;
until (startmess <> -1) or not cts;
if startmess = 0 then getfirst := 0
else getfirst := findfirst(startmess);
end;

procedure readfrom;

var
fromnum: integer;
first: byte;

begin
if cts then begin
fromnum := getid('Enter name of sender: ');
if fromnum < 1
then stringout('Not a registered user name.')
else begin
first := getfirst;
if first > 0 then messagesearch(first, fromnum, 0, 0);
end;
end;
end;

procedure readto;

var
tonum: integer;
first: byte;

begin
if cts then begin
tonum := getid('Enter name of addressee: ');
if tonum < 1
then stringout('Not a registered user name.')
else begin
first := getfirst;
if first > 0 then messagesearch(first, 0, tonum, 0);
end;
end;
end;

procedure readsect;

var
first: byte;
inch: integer;

begin
if cts then repeat
if sectsin then
inch := getint(numsects, 0, 'Enter section number (0 for all, ? for list): ')
else inch := 1;
case inch of
-1 : listsections;
0..numsects: begin
first := getfirst;
if first > 0 then messagesearch(first, 0, 0, inch);
end;
end;
until (inch <> -1) or not cts;
end;

procedure receive;

var
uchar: char;

begin
if cts then begin
clearsc;
if not expert then outfile(readmenu);
repeat
uchar := getcap('Read mode: (A,I,F,T,S, or ? for menu)? ');
if uchar = '?' then outfile(readmenu);
until (uchar in ['A','I','F','T','S',cr]) or not cts;
if uchar = 'I' then readind;
if cts and (uchar <> 'I') then begin
case uchar of
'A': messagesearch(getfirst,0,0,0);
'F': readfrom;
'T': readto;
'S': readsect;
end;
end;
end;
end;

procedure closemess;

var
loop: byte;

begin
rewrite(messagefile);
for loop := 1 to count do
write(messagefile, messtable[loop]);
close(messagefile);
messopen := false;
end;

{make "enter" an overlay procedure and make filesys another one to save space}
procedure enter;

var
tabloc: byte;
messbuff: messtext;
linenum: byte;
inch: char;

procedure compose(var block: messtext; var linenum: byte);

var
temp: name;

begin
lineout(cr + lf + 'Enter message text: ' + maxlenstr + ' lines of 80 chars max.');
lineout('An empty line ends entry. "." at start of line forces new line.');
lineout(space);
if linenum < maxlength then repeat
linenum := linenum + 1;
str(linenum:2, temp);
stringout(temp + ': ');
block[linenum] := inputstring(echo);
until (linenum = maxlength) or (block[linenum] = '') or not cts;
if block[linenum] = '' then linenum := linenum - 1;
end;

procedure list(var block: messtext; first, last: byte);

var
loop: byte;
temp: name;

begin
if (first > 0) and (last > 0) and cts then begin
loop := first;
while (loop <= last) and (not cancelled) and cts do begin
str(loop:2, temp);
stringout(temp + ': ');
lineout(block[loop]);
loop := loop + 1;
end;
lineout(space);
end;
end;

procedure delline(var block: messtext; linenum: byte; var maxline: byte);

var temp: char;
loop: byte;

begin
list(block, linenum, linenum);
if cts and (linenum > 0) then begin
temp := getcap('Delete: are you sure (Y/N)? ');
if temp = 'Y' then begin
for loop := linenum+1 to maxline do block[loop-1] := block[loop];
block[maxline] := '';
maxline := pred(maxline);
lineout('Line deleted.');
end;
end;
end;

procedure edit(var block: messtext; linenum: byte);

var
oldstring: line;
newstring: line;
posn : integer;

begin
if (linenum > 0) and cts then begin
list(block, linenum, linenum);
oldstring := getinput('Enter string to replace: ', 80, echo);
newstring := getinput('Enter replacement: ', 80, echo);
posn := pos(oldstring, block[linenum]);
if posn <> 0 then begin
delete(block[linenum], posn, length(oldstring));
insert(newstring, block[linenum], posn);
list(block, linenum, linenum);
end
else lineout('Old string not found.');
lineout(space);
end;
end;

procedure replace(var block: messtext; linenum: byte);

begin
if (linenum > 0) and cts then begin
lineout('Old line:');
list(block, linenum, linenum);
lineout('Enter new line:');
stringout('? ');
block[linenum] := inputstring(echo);
end;
end;

function whichline(linenum: byte): byte;

var
temp: name;
x : integer;

begin
str(linenum:2, temp);
x := getint(linenum, 0, ' Which line? (1 - ' + temp + ')? ');
if (x <= 0) or not cts then whichline := 0 else whichline := x;
end;

procedure newheader(var entry: messages);

var
temp, tonum: integer;

begin
if cts then begin
entry.sender := usernum;
tonum := getid('Who to (RETURN or ENTER key for ALL)? ');
if tonum = 0 then lineout('Message to: ALL');
entry.recver := tonum;
entry.subject := getinput('Subject (14 characters max.)? ', 14, echo);
if clockin then begin
clock(month, date, hour, min, sec);
entry.date := time(month, date, hour, min, sec);
end;
if sectsin then repeat
temp := getint(numsects, 0, 'Which section (or "?" for list)? ');
if temp = -1 then listsections;
if temp in [1..numsects] then entry.section := temp;
until (temp in [1..numsects]) or not cts
else entry.section := 1;
if tonum > 0 then entry.private := getcap('Private message (Y/N)? ')='Y'
else entry.private := false;
entry.reply := 0;
entry.repto := 0;
entry.number := nextmess;
entry.recved := false;
end;
end;

procedure storemess(var block: messtext; tabloc, lastline: byte);

var
outfile: text;
linenum: byte;

begin
if cts then begin
lineout('Writing message to disk...');
assign(outfile, namemess(nextmess));
rewrite(outfile);
linenum := 1;
while linenum <= lastline do begin
if (copy(block[linenum],1,1) = '.') or preformat then begin
writeln(outfile);
if not preformat then
block[linenum] := copy(block[linenum], 2, length(block[linenum])-1);
end
else write(outfile, ' ');
write(outfile, block[linenum]);
linenum := linenum + 1;
end;
writeln(outfile);
close(outfile);
nextmess := nextmess + 1;
count := count + 1;
end;
end;

begin
preformat := false;
if cts then begin
clearsc;
if access < reg then lineout('You cannot enter messages yet: Use [A]pply command.')
else begin
tabloc := count + 1;
if tabloc > maxmess then lineout('No message space left.')
else begin
repeat
newheader(messtable[tabloc]);
header(tabloc);
inch := getcap('Is this OK (Y/N/Abort)? ');
until (inch <> 'N') or not cts;
if inch <> 'A' then begin
linenum := 0;
compose(messbuff, linenum);
if not expert then outfile(editmenu);
repeat
inch := getcap('Edit command: A,C,D,E,L,P,R,S or ? for menu? ');
case inch of
'C': compose(messbuff, linenum);
'D': delline(messbuff, whichline(linenum), linenum);
'E': edit(messbuff, whichline(linenum));
'L': list(messbuff, whichline(linenum), linenum);
'P': begin preformat := true; storemess(messbuff, tabloc, linenum); end;
'R': replace(messbuff, whichline(linenum));
'S': storemess(messbuff, tabloc, linenum);
'?': outfile(editmenu);
end;
until (inch = 'A')
or (inch = 'S')
or (inch = 'P')
or not cts;
end;
end; {2nd else}

end; {1st else}
end; {if cts}
end; {enter}


  3 Responses to “Category : Pascal Source Code
Archive   : TBBS.ZIP
Filename : MAILSYS.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/