home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #1
/
monster.zip
/
monster
/
BBS_GAME
/
LOD400E.ZIP
/
PROGRAMR.ZIP
/
MESSAGES.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-09-21
|
9KB
|
407 lines
unit messages;
{$O+,F+,V-}
interface
uses crt, globals, gtscott, ddlod, misc, messgio;
const
default_fore=lightcyan;
procedure EnterMessage(replyname,replysub: string);
procedure NewMail;
procedure ReadMail;
implementation
function msgok(attr: word; var mfrom,mto: string): boolean;
begin;
if (attr and 1)<>1 then begin;
msgok:=true;
exit;
end;
msgok:=false;
if stu(user.alias)=stu(mfrom) then msgok:=true;
if stu(user.alias)=stu(mto) then msgok:=true;
end;
procedure DispMessage(msgnum: word);
var
mr: message_ptr;
b,c: integer;
quit,nonstop: boolean;
ch: char;
begin;
new(mr);
Get_Message(msgnum,mr^);
sclrscr;
if not MsgOk(mr^.attribute,mr^.from,mr^.m_to) then begin;
outstr(2500);
dispose(mr);
exit;
end;
if (stu(mr^.from)='DELETED') or (stu(mr^.m_to)='DELETED') then begin;
outstr(2501);
dispose(mr);
exit;
end;
outstr(2502); swrite(va(msgnum));
while swherex<40 do swrite(' ');
outstr(2503); swriteln(mr^.datetime);
outstr(2504); swrite(mr^.from);
if (mr^.attribute and 1)<>0 then begin;
while swherex<40 do swrite(' ');
outstr(2507);
end else swriteln('');
outstr(2505); swriteln(mr^.m_to);
outstr(2506); swriteln(mr^.subject);
outstr(2509);
c:=5;
quit:=false;
nonstop:=false;
for b:=1 to mr^.lines do if (not quit) then begin;
inc(c);
swriteln(mr^.text[b]);
if (c=23) and (not quit) then begin;
getcnsprompt(ch);
if ch='S' then quit:=true;
if ch='N' then nonstop:=true;
c:=0;
end;
end;
set_foreground(default_fore);
dispose(mr);
end;
procedure enter_wordwrap(var mr: message_Rec);
var
s,s2: string[162];
a,b,c: integer;
ch: char;
done: boolean;
begin;
done:=false;
a:=mr.lines+1;
mr.text[a]:='';
repeat;
set_foreground(default_fore);
s:=va(a)+':';
if length(s)=2 then s:=' '+s;
swrite(s);
set_foreground(15);
repeat;
sread_char(ch);
if (ch=#8) and (length(mr.text[a])>0) then begin;
swrite(#8+' '+#8);
delete(mr.text[a],length(mr.text[a]),1);
end;
if not (ch in [#$0d,#$08]) then begin;
mr.text[a]:=mr.text[a]+ch;
swrite(ch);
end;
if (ch=#$0d) and (length(mr.text[a])<>0) then mr.text[a]:=mr.text[a]+ch;
if length(mr.text[a])>72 then begin;
c:=0;
for b:=1 to length(mr.text[a]) do if mr.text[a][b]=' ' then c:=b;
s:='';
if c>60 then begin;
for b:=c+1 to length(mr.text[a]) do begin;
s:=s+mr.text[a][b];
swrite(#8+' '+#8);
end;
for b:=c to length(mr.text[a]) do delete(mr.text[a],length(mr.text[a]),1);
end;
a:=a+1;
swriteln('');
set_foreground(default_fore);
s2:=va(a)+':';
if length(s2)=2 then s2:=' '+s2;
swrite(s2);
set_foreground(15);
swrite(s);
mr.text[a]:=s;
end;
until ch=#13;
if length(mr.text[a])<>0 then begin;
swriteln('');
a:=a+1;
mr.text[a]:='';
end else done:=true;
if a=max_msg_lines then begin;
a:=a+1;
outstr(2510);
done:=true;
end;
until done;
mr.lines:=a-1;
swriteln('');
set_foreground(default_fore);
end;
procedure EnterMessage(replyname,replysub: string);
var
private: boolean;
fname: string;
mr: message_ptr;
s: string[128];
a,b: integer;
mnum: word;
begin;
if maxavail<16384 then begin;
outstr(2511);
waitkey;
exit;
end;
new(mr);
sclrscr;
set_foreground(green);
outstr(2512);
swriteln(namestr(user.alias));
outstr(2513);
if replyname<>'' then begin;
mr^.m_to:=namestr(replyname);
swriteln(mr^.m_to);
end else begin;
prompt(mr^.m_to,30,false);
mr^.m_to:=namestr(mr^.m_to);
end;
outstr(2514);
if replysub<>'' then begin;
if pos('RE:',stu(replysub))=0 then mr^.subject:='Re: '+replysub else mr^.subject:=replysub;
swriteln(mr^.subject);
end else begin;
prompt(mr^.subject,50,false);
end;
mr^.datetime:=getfidodate;
outstr(2515);
swriteln(mr^.datetime);
private:=false;
outstr(2516);
sread(s);
swriteln('');
if length(s)>=1 then if (s[1]='Y') or (s[1]='y') then private:=true;
mr^.from:=namestr(user.alias);
mr^.attribute:=00;
if private then mr^.attribute:=mr^.attribute or 1;
mr^.replyto:=00;
mr^.nextreply:=00;
for a:=1 to max_msg_lines do mr^.text[a]:='';
outstr(2517);
mr^.lines:=0;
mnum:=find_highest_message+1;
enter_wordwrap(mr^);
repeat;
outstr(2518);
sread(s);
set_foreground(default_fore);
s:=stu(s);
if s='C' then if mr^.lines=175 then begin;
outstr(2519);
end else begin;
enter_wordwrap(mr^);
end;
if s='I' then begin;
if mr^.lines=0 then begin;
outstr(2520);
end else begin;
outstr(2521);
swrite(wva(mr^.lines));
outstr(2522);
sread_num(a);
if (a<1) or (a>mr^.lines) then begin;
outstr(2524);
end else begin;
outstr(2523);
swrite('>');
prompt(s,77,true);
for b:=mr^.lines downto a do mr^.text[b+1]:=mr^.text[b];
mr^.text[a]:=s;
mr^.lines:=mr^.lines+1;
s:='I';
end;
end;
end;
if s='D' then begin;
if mr^.lines=0 then begin;
outstr(2525);
swriteln('No lines in message to delete.');
end else begin;
outstr(2526);
swrite(wva(mr^.lines));
outstr(2527);
sread_num(a);
if (a<1) or (a>mr^.lines) then begin;
outstr(2524);
end else begin;
if a<>mr^.lines then for b:=a to mr^.lines-1 do mr^.text[b]:=mr^.text[b+1];
mr^.lines:=mr^.lines-1;
end;
end;
end;
if s='E' then begin;
if mr^.lines=0 then begin;
outstr(2528);
end else begin;
outstr(2529);
swrite(wva(mr^.lines));
outstr(2530);
sread_num(a);
if (a<1) or (a>mr^.lines) then begin;
outstr(2524);
end else begin;
outstr(2531);
swrite('>');
prompt(mr^.text[a],77,true);
end;
end;
end;
if s='L' then begin;
sclrscr;
for a:=1 to mr^.lines do begin;
s:=va(a)+':';
if length(s)=2 then s:=' '+s;
swrite(s);
set_foreground(15);
swriteln(mr^.text[a]);
set_foreground(default_fore);
end;
end;
until (s='S') or (s='A');
if s='S' then begin;
swriteln('Saving message....');
{ for a:=1 to mr^.lines-1 do begin;
if mr^.text[a][length(mr^.text[a])]<>#13 then mr^.text[a]:=mr^.text[a]+#13;
end;}
add_message(mnum,mr^);
end else outstr(2532);
dispose(mr);
end;
procedure NextMsg(var mnum: word);
var
mr: message_ptr;
himsg: word;
begin;
new(mr);
HiMsg:=Find_highest_message;
repeat;
inc(mnum);
if mnum<=himsg then Get_message_header(mnum,mr^);
until (msgok(mr^.attribute,mr^.from,mr^.m_to)) or (mnum>HiMsg);
if mnum>himsg then mnum:=himsg;
dispose(mr);
end;
procedure PrevMsg(var mnum: word);
var
mr: message_ptr;
begin;
new(mr);
repeat;
dec(mnum);
if mnum>0 then Get_message_header(mnum,mr^);
until (msgok(mr^.attribute,mr^.from,mr^.m_to)) or (mnum=0);
if mnum=0 then mnum:=1;
dispose(mr);
end;
procedure DoReply(mnum: word);
var
mr: message_ptr;
fromname, fromsubj: string[80];
begin;
new(mr);
Get_message_header(mnum,mr^);
fromname:=mr^.from;
fromsubj:=mr^.subject;
dispose(mr);
EnterMessage(fromname,fromsubj);
end;
procedure NewMail;
var
a,himsg,start: word;
mr: message_ptr;
b: boolean;
nummsg: word;
begin;
if maxavail<16384 then begin;
outstr(2533);
waitkey;
exit;
end;
new(mr);
start:=user.lastread;
himsg:=Find_highest_message;
if start>himsg then start:=himsg;
start:=start+1;
nummsg:=0;
if (start<=himsg) or (himsg=0) then begin;
for a:=start to himsg do begin;
Get_message_header(a,mr^);
b:=false;
if (stu(mr^.m_to)=user.alias) or (stu(mr^.m_to)=user.realname) then b:=true;
if (mr^.attribute and 1)<>1 then b:=true;
if b then inc(nummsg);
end;
end;
if nummsg=0 then outstr(2534) else begin;
set_foreground(white);
swrite(wva(nummsg));
outstr(2547);
end;
dispose(mr);
end;
procedure ReadMail;
var
s: string[128];
mnum: word;
lastdir: char;
himsg: word;
a,b: integer;
begin;
if maxavail<16384 then begin;
outstr(2535);
waitkey;
exit;
end;
set_Foreground(lightcyan);
swriteln('<Read Mail>');
set_foreground(default_fore);
mnum:=user.lastread;
himsg:=find_highest_message;
if himsg=0 then begin;
outstr(2536);
waitkey;
exit;
end;
if mnum>himsg then mnum:=himsg;
if mnum=0 then mnum:=1;
lastdir:='N';
repeat;
DispMessage(mnum);
outstr(2537);
swrite(wva(mnum));
outstr(2538);
swrite(wva(Find_highest_message));
outstr(2539);
sread(s);
s:=stu(s);
set_foreground(default_fore);
if s='' then if lastdir='N' then NextMsg(mnum) else PrevMsg(mnum);
val(s,a,b);
if (a>=1) and (a<=himsg) then mnum:=a;
if (s='N') then begin;
NextMsg(mnum);
lastdir:='N';
end;
if (s='P') then begin;
PrevMsg(mnum);
lastdir:='P';
end;
if (s='R') then DoReply(mnum);
until s='Q';
user.lastread:=mnum;
end;
end.