Oakland CPM Archive/oakcpm.iso/cpm/bbs/tpbbs10.ark/TPMS10.INC

Text File | 1986-09-14 | 14.4 KB | 719 lines

{**************************************************}
{  TPMESG.INC   This module includes all of the    }
{  message base procedures for TPBBS.              }
{**************************************************}

procedure msgprompt(tag:password);

begin
line1:='Msg #';
if not xpr then
 begin
  str(mfirst,temp);
  line1:=line1+' ('+temp;
  str(mlast,temp);
  line1:=line1+' - '+temp+') to '+tag;
 end;
line1:=line1+'? ';
n:=1;
printstring;
end;


procedure entrmsg;
var aa : allstrings;

label getname,found,enttxt,mantxt,abort,done;
begin
   str(mlast+1,temp);
   line:='Msg # will be '+temp;
   printstring;
  getname: line1:='To (C/R for all)? ';n:=1;
  printstring;
  c:=1;getstring;c:=0;
  if bstring='' then bstring:='ALL';
  whoto:=bstring;
  aa:=whoto;
  if whoto='SYSOP' then goto found;
  if whoto<>'ALL' then
   begin
    assign(user_file,drive2+'USER'+ext);
    reset(user_file);
    while not eof(user_file) do
    begin
     read(user_file,user_rec);
     with user_rec do
     begin
      if aa=name then goto found;
     end;
    end;
    line1:='Not a known user. OK(Y/N)? ';n:=1;
    printstring;
    getstring;
    bstring:=copy(bstring,1,1);
    bstring:=stupcase(bstring);
    if bstring<>'Y' then
     begin
     close(user_file);
     goto getname;
     end;
   end;
  found: line1:='Subject? ';n:=1;
  printstring;
  getstring;
  if bstring='' then goto abort;
  subto:=bstring;
  line1:='Private message (Y/N)? ';n:=1;
  printstring;
  getstring;
  if bstring='' then bstring:='N';
  dd:=copy(bstring,1,1);
  dd:=stupcase(dd);
  if dd='Y' then passto:='*' else passto:='';
  if not xpr then
   begin
    line:='Enter up to 15 lines of text (NO semicolons).';
    printstring;
    line:='Type C/R on blank line to end.';
    printstring;
   end;
  line:='   I------------------------------------------------------------I';
  printstring;
  lc:=1;

enttxt: while (lc<16) and (bstring<>'') do
  begin
   str(lc,temp);
   if lc<10 then line1:=' '+temp+'>' else line1:=temp+'>';
   n:=1;printstring;
   getstring;
   if bstring<>'' then messbuff[lc]:=bstring;
   if lc>12 then
    begin
     str(15-lc,temp);
     line:='('+temp+' lines left)';
     printstring;
    end;
   lc:=lc+1;
  end;
 if lc=16 then lc:=15 else lc:=lc-2;

mantxt:
 if lc=0 then goto abort;
 writeln;
 if xpr then line1:='L,E,A,C,S: ' else line1:='L)ist E)dit A)bort C)ontinue S)ave: ';
 n:=1;
 printstring;
 getstring;
 if bstring='' then goto mantxt;
 aa:=stupcase(bstring);
 a:=pos(aa,'LEACS');
  case a of
   1: begin          {List}
      line:='To:  '+whoto;
      printstring;
      line:='Re:  '+subto;
      printstring;
      line:='PW:  '+passto;
      printstring;
      writeln;
      for i:=1 to lc do
       begin
        str(i,temp);
        if i<10 then line:=' '+temp+'>' else line:=temp+'>';
        line:=line+messbuff[i];printstring;
       end;
      end;

 2: begin            {Edit}
      if not xpr then
       begin
        line:='Enter line number to change (C/R to end).';
        printstring;
        line:='Then enter replacement or C/R for no change.';
        printstring;
       end;
      line1:='Line #? ';n:=1;
      printstring;
      getstring;
      makenum;
       if (x>0) and (x<=lc) then
        begin
         if not xpr then line:='Was:';printstring;
         str(x,temp);
         if x<10 then line:=' '+temp+'>' else line:=temp+'>';
         line:=line+messbuff[x];printstring;
         if x<10 then line1:=' '+temp+'>' else line1:=temp+'>';
         n:=1;printstring;
         getstring;
         if bstring<>'' then messbuff[x]:=bstring;
        end;
    end;

 3: goto abort;      {Abort}

 4: begin            {Continue}
     lc:=lc+1;if lc<16 then goto enttxt;
    end;

 5: begin            {Save}
     line1:='Updating system files...';
     n:=1;printstring;

 {Counters}
     assign(stat_file,drive2+'COUNTERS'+ext);
     reset(stat_file);
     read(stat_file,stat_rec);
     with stat_rec do
      begin
       seek(stat_file,filepos(stat_file)-1);
       message_pointer:=message_pointer+1;
       msgs:=message_pointer;
       calls:=calls;
       mlast:=mlast+1;
       if mfirst=0 then mfirst:=1;mstart:=1;
       mnum:=mlast;
       seek(summary_file,1);
       write(stat_file,stat_rec);
       close(stat_file);
      end;

 {Summary}
     assign(summary_file,drive3+'SUMMARY'+ext);
     {$I-}
     reset(summary_file);
     {$I+}
     if ioresult<>0 then
     begin
      rewrite(summary_file);
     end;
     if ioresult=0 then
     begin
      seek(summary_file,filesize(summary_file));
     end;
     with summary_rec do
      begin
       msgnum:=mlast;
       person_from:=firstname+' '+lastname;
       person_to:=whoto;
       subject:=subto;
       mdate:=pdate;
       mpassword:=passto;
       no_of_lines:=lc;
       write(summary_file,summary_rec);
      end;
      close(summary_file);

{Messages}
      assign(message_file,drive3+'MESSAGES'+ext);
      {$I-}
      reset(message_file);
      {$I+}
      if ioresult<>0 then rewrite(message_file)
      else seek(message_file,filesize(message_file));
      with message_rec do
       begin
        str(mlast,temp);
        msgtext:=temp;
        write(message_file,message_rec);
        msgtext:=firstname+' '+lastname;
        write(message_file,message_rec);
        msgtext:=whoto;
        write(message_file,message_rec);
        msgtext:=subto;
        write(message_file,message_rec);
        if clock then
         begin
          getdate;
          gettime;
         end;
        msgtext:=pdate+'  '+ptime;
        write(message_file,message_rec);
        msgtext:=passto;
        write(message_file,message_rec);
        for i:= 1 to lc do
         begin
          msgtext:=messbuff[i];
          write(message_file,message_rec);
         end;
        msgtext:='9999';
        write(message_file,message_rec);
       end;
      close(message_file);
    writeln;
    goto done;
 end;
end;
goto mantxt;

line:='Entry finished.';
printstring;
close(user_file);
abort: line:='++ Aborted ++';
printstring;
done:;
end;

{get a record from the message file, put it in temp}
procedure readrec;

begin
read(message_file,message_rec);
with message_rec do
 begin
  temp:=msgtext;
 end;
end;

procedure readmsg;

label query,search,read1,read2,read3,read4,loop,loop1,skip,done;

begin
fflag:=false;
query: writeln;
 option:=' ';
 msgprompt('Read');
 getstring;
 if bstring='' then goto done;
 makenum;
 rnum:=x;
 if dd='+' then option:='+';
 writeln;
 if (rnum<mfirst) or (rnum>mlast) then
  begin
   line:='++ No such msg ++';
   printstring;
   goto query;
  end;
 writeln;
 fflag:=true;
 assign(message_file,drive3+'MESSAGES'+ext);
 {$I-}
 reset(message_file);
 {$I+}
 if ioresult<>0 then goto query;
 search:
 while not eof(message_file) do
  begin
   readrec;
   bstring:=temp;
   makenum;
   if (x=0) or (x=30000) then goto skip;
   if rnum=x then goto read1;
   if rnum<x then goto loop;
skip: while temp<>'9999' do
       begin
        readrec;
       end;
  end;
goto done;

loop:
if option<>'+' then
 begin
  line:='++ Message not found ++';
  printstring;
  goto query;
 end;

read1:
 str(x,msghead[1]);
 for i:=2 to 5 do
  begin
   readrec;
   msghead[i]:=temp;
  end;
 readrec;
 if firstname='SYSOP' then goto read2;
 if temp='*' then
  begin
   line:=stupcase(firstname)+' '+stupcase(lastname);
   temp2:=stupcase(msghead[2]);
   if line<>temp2 then
    begin
     temp2:=stupcase(msghead[3]);
     if line<>temp2 then goto loop1;
    end;
   writeln;
   goto read2;
  end;
 writeln;
 goto read2;

loop1:
while temp<>'9999' do
 begin
  readrec;
 end;
 writeln('Private message.');
 writeln;
 if option='+' then goto search;
 goto read4;

read2:
 line:='Msg #  :'+msghead[1];
 printstring;
 line:='From   :'+msghead[2];
 printstring;
 line:='To     :'+msghead[3];
 printstring;
 line:='Subject:'+msghead[4];
 printstring;
 line:='Date   :'+msghead[5];
 printstring;
 writeln;

read3:
  readrec;
  if temp<>'9999' then
   begin
    line:=temp;
    printstring;
    goto read3;
   end;

read4:
writeln;
if option<>'+' then goto query;
if page then pprompt;
if dd='N' then goto done;
goto search;

done:
if fflag=true then
 close(message_file);
fflag:=false;
end;

procedure summinit;
label foundstart,done;

begin
fflag:=false;
writeln;
msgprompt('Start');
getstring;
makenum;
rnum:=x;
writeln;
line:='';
if rnum>mlast then
 begin
  line:='++ No such msg ++';
  printstring;
  goto done;
 end;

fflag:=true;
assign(summary_file,drive3+'SUMMARY'+ext);
reset(summary_file);
while not eof(summary_file) do
 begin
  read(summary_file,summary_rec);
  with summary_rec do
   begin
    if msgnum>=rnum then goto foundstart;
   end;
 end;

foundstart:
seek(summary_file,filepos(summary_file)-1);

done:
end;


procedure summarize;
label skip,done;

begin
summinit;
if fflag=false then goto done;
if line<>'' then goto done;
while not eof(summary_file) do
 begin
  read(summary_file,summary_rec);
  with summary_rec do
   begin
   if mpassword<>'' then
    dd:=copy(mpassword,1,1);
    if msgnum<>0 then
     begin
      str(msgnum,temp);z:=length(temp);
      line:=temp;
      if z<4 then
       begin
       for i:=z+1 to 4 do
        begin
         line:=' '+line;
        end;
       end;
      line:=line+': ';
      str(no_of_lines,temp);
      pad(temp,3);
      line:=line+temp+mdate+' ';
      temp:=person_from;
      z:=pos('SYSOP',temp);
      if z=0 then
       begin
        z:=pos(' ',temp);
        temp:=copy(temp,z+1,length(temp)-z);
       end;
      pad(temp,10);
      line:=line+temp+' => ';
      temp:=person_to;
      z:=pos(' ',temp);
      temp:=copy(temp,z+1,length(temp)-z);
      pad(temp,10);
      line:=line+temp;
      temp:=subject;
      if dd='*' then temp:='(Private)';
      line:=line+temp;
      printstring;
      dd:=' ';
     end;
   end;
  skip:
 end;
done:
writeln;
if fflag=true then close(summary_file);
fflag:=false;
writeln;
end;


procedure qwik_summary;
label skip,done;

begin
summinit;
if fflag=false then goto done;
if line<>'' then goto done;
temp2:=stupcase(firstname)+' '+stupcase(lastname);

while not eof(summary_file) do
 begin
  read(summary_file,summary_rec);
  with summary_rec do
   begin
    if mpassword<>'' then
     dd:=copy(mpassword,1,1);
    if msgnum<>0 then
     begin
      str(msgnum,temp);
      line:=temp+'  ';
      temp:=subject;
      if dd='*' then temp:='(Private)';
      line:=line+temp;
      printstring;
      dd:=' ';
      skip:
     end;
   end;
 end;
done:
writeln;
if fflag=true then close(summary_file);
fflag:=false;
writeln;
end;


procedure killmsg;
label query,kill1,kill2,kill3,done;

begin
query: writeln;
 msgprompt('Kill');
 getstring;
 makenum;
 knum:=x;
 writeln;
 if bstring='' then goto done;
 if (knum<mfirst) or (knum>mlast) then
  begin
   line:='++ No such msg ++';
   printstring;
   goto query;
  end;
 line1:='Scanning message base...';n:=1;
 printstring;
 assign(summary_file,drive3+'SUMMARY'+ext);
 reset(summary_file);
 while not eof(summary_file) do
  begin
   read(summary_file,summary_rec);
   with summary_rec do
    begin
     if knum=msgnum then
      begin
       if firstname='SYSOP' then goto kill1;
       temp:=stupcase(firstname+' '+lastname);
       line:=stupcase(person_from);
       if line=temp then goto kill1;
       line:=stupcase(person_to);
       if line=temp then goto kill1;
       writeln;
       line:='++ That message doesn''t belong to you ++';
       printstring;
       goto done;
      end;
    end;
  end;
 line:='++ Message not found ++';
 printstring;
 goto query;

kill1:
writeln;
line1:='Updating system files...';n:=1;
printstring;
with summary_rec do
  begin
   seek(summary_file,filepos(summary_file)-1);
   msgnum:=0;
   write(summary_file,summary_rec);
  end;
close(summary_file);

kill2:
assign(message_file,drive3+'MESSAGES'+ext);
reset(message_file);
while not eof(message_file) do
 begin
  read(message_file,message_rec);
  with message_rec do
   begin
    bstring:=msgtext;
    makenum;
    if knum=x then
     begin
      seek(message_file,filepos(message_file)-1);
      msgtext:='0:'+msgtext+' '+firstname+' '+lastname;
      write(message_file,message_rec);
      goto kill3;
     end;
   end;
 end;

kill3:
close(message_file);
assign(stat_file,drive2+'COUNTERS'+ext);
reset(stat_file);
read(stat_file,stat_rec);
seek(stat_file,filepos(stat_file)-1);
with stat_rec do
 begin
  message_pointer:=message_pointer-1;
  msgs:=message_pointer;
  calls:=calls;
  mstart:=mstart;
  mnum:=mnum;
  write(stat_file,stat_rec);
 end;
close(stat_file);
writeln;
line:='Message killed.';
printstring;
goto query;

done:
end;

procedure get_mcommand;
label start;

begin
 start:
  ff:=0;
  line1:='[M]Function:';
  if not xpr then
    line1:=line1+'E,R,S,Q,K,C,G,A (? for HELP)';
  line1:=line1+'?';
  n:=1;
  printstring;
  n:=0;
  c:=1;
  getstring;
  c:=0;
  if bstring<>'' then
   begin
    ff:=pos(bstring,'ERSQK?ACG');
    if ff=0 then
      begin
        line:='I don'+''''+'t understand '+''''+bstring+''''+', '+firstname+'.';
        printstring;
        writeln;
        save:='';
        goto start;
      end;
   end;
end;

procedure do_mcommand;
begin

case ff of

 1: begin
     entrmsg;
    end;

 2: begin
     readmsg;
    end;

 3: begin
     if mlast<>0 then summarize;
    end;

 4: begin
     if mlast<>0 then qwik_summary;
    end;

 5: begin
     killmsg;
    end;

 6: begin
     writeln;
     line:='            [Message system menu]';
     printstring;
     line:='E: Enter message         R: Retrieve message';
     printstring;
     line:='S: Scan messsages        Q: Qwik-scan messages';
     printstring;
     line:='K: Kill message          C: Exit to CP/M';
     printstring;
     line:='G: Goodbye (logoff)      A: Abort to main system';
     printstring;
     writeln;
    end;

 7: begin
     eflag:=0;
    end;

 8: begin
     exit_to_cpm;
    end;

 9: begin
     goodbye;
    end;

end;
end;
begin
     eflag:=0;
    end;

 8: begin
     exit_to_cpm;
    end;

 9: begin
     goodbye;