{$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+}

unit email;

interface

uses windows,gentypes,configrt,gensubs,subs1,subs2,textret,flags,
     mailret,userret,overret1,mainr1,mainr2,others;

procedure opengfile;
procedure autoreply;
procedure editmailuser;
procedure newmailre;
procedure emailmenu;

implementation

var lastread:integer;
    m:mailrec;
    incoming,outgoing:catalogrec;


  procedure addcatalog (var c:catalogrec; var m:mailrec; fpos:integer);
  begin
    m.fileindex:=fpos;
    if c.nummail=maxcatalogsize
      then c.additional:=c.additional+1
      else begin
        c.nummail:=c.nummail+1;
        c.mail[c.nummail]:=m
      end
  end;

  procedure writenummail (var c:catalogrec; txt:mstr);
  begin
    writeln (^B^M'You have ',c.nummail+c.additional,' ',txt,
             ' message',s(c.nummail));
    if c.additional>0
      then writeln ('   Note: Of those, ',
                     numthings (c.additional,'is','are'),' uncataloged.')
  end;

  procedure readcatalogs;
  var m:mailrec;
      cnt:integer;
  begin
    seek (mfile,1);
    incoming.nummail:=0;
    incoming.additional:=0;
    outgoing.nummail:=0;
    outgoing.additional:=0;
    for cnt:=1 to filesize(mfile)-1 do begin
      read (mfile,m);
      if m.sentto=unum
        then addcatalog (incoming,m,cnt);
      if match(m.sentby,unam)
        then addcatalog (outgoing,m,cnt)
    end
  end;

  procedure readit (var m:mailrec);
  begin
  clearscr;
  writeln(^B'[ E-Mail ]');
    write (^B^M'Title:   '^S,m.title,^M'Sent by: '^S);
    if m.anon
      then
        begin
          write (configset.anonymousst);
          if issysop then write (' (',m.sentby,')')
        end
      else write (m.sentby);
    writeln (^M'Sent at: '^S,datestr(m.when),' at ',timestr(m.when));
    writeln;
    ansicolor(urec.regularcolor);
    if not break then printtext (m.line)
  end;

  procedure readincoming (n:integer);
  var m:^mailrec;
      cnt:integer;
  begin
    m:=addr(incoming.mail[n]);
    readit (m^);
    if not (m^.read) then begin
      m^.read:=true;
      seek (mfile,m^.fileindex);
      write (mfile,m^)
    end;
    for cnt:=n+1 to incoming.nummail do
      if match(incoming.mail[cnt].sentby,m^.sentby) then begin
        writeln (^B^M'There''s more mail from ',m^.sentby,'!');
        exit
      end
  end;

  procedure listmail (var c:catalogrec);
  var n:integer;
      u:userrec;
      cnt:integer;
      m:mailrec;
  begin
    write ('Num  ');
    tab ('Title',30);
    write ('New  Sent ');
    if ofs(c)=ofs(incoming) then writeln ('by'^M) else writeln ('to'^M);
    if break then exit;
    for cnt:=1 to c.nummail do if not break then begin
      m:=c.mail[cnt];
      write (cnt:2,'.  ');
      if not break then tab (m.title,30);
      if not break then if m.read then write ('     ') else write ('New  ');
      if match(m.sentby,unam)
        then writeln (lookupuname (m.sentto))
        else writeln (m.sentby)
    end
  end;

  procedure writemail (var c:catalogrec; num:integer);
  begin
    seek (mfile,c.mail[num].fileindex);
    write (mfile,c.mail[num])
  end;

  function checklastread:boolean;
  begin
    if (lastread<0) or (lastread>incoming.nummail) then lastread:=0;
    checklastread:=lastread=0
  end;

  function getmsgnumber (var c:catalogrec; txt:sstr):integer;
  var n:integer;
      inc:boolean;
  begin
    inc:=ofs(c)=ofs(incoming);
    getmsgnumber:=0;
    if c.nummail=0 then begin
      if c.additional>0 then readcatalogs;
      if c.nummail=0 then writestr (^M'Sorry, no mail!');
      if inc then lastread:=0;
      exit
    end;
    input:=copy(input,2,255);
    if length(input)=0
      then if inc
        then n:=lastread
        else n:=0
      else n:=valu(input);
    if (n<1) or (n>c.nummail) then begin
      repeat
        writestr (^M'Message number to '+txt+' [?=list]:');
        if length(input)=0 then exit;
        if input='?' then listmail (c)
      until input<>'?';
      n:=valu(input);
      if (n<1) or (n>c.nummail) then n:=0
    end;
    getmsgnumber:=n
  end;

  procedure deletemail (var c:catalogrec; n:integer);
  begin
    delmail (c.mail[n].fileindex);
    writeln (c.mail[n].title,' by ',c.mail[n].sentby,' deleted.');
    readcatalogs
  end;

  procedure nextmail;
  begin
    lastread:=lastread+1;
    if lastread>incoming.nummail
      then
        begin
          lastread:=0;
          if incoming.additional>0
            then writeln ('You must delete some old mail first!')
            else writeln ('Sorry, no more mail!')
        end
      else readincoming (lastread)
  end;

  procedure readnum (n:integer);
  begin
    if (n<1) or (n>incoming.nummail) then begin
      lastread:=0;
      exit
    end;
    lastread:=n;
    readincoming (n)
  end;

  procedure readmail;
  begin
    readnum (getmsgnumber (incoming,'read'))
  end;

  procedure listallmail;
  begin
    if incoming.nummail>0 then begin
      writehdr ('Incoming mail');
      listmail (incoming)
    end;
    if outgoing.nummail>0 then begin
      writehdr ('Outgoing mail');
      listmail (outgoing)
    end
  end;

  procedure newmailre;
  begin
  close(gfile);
  opengfile;
  readcatalogs;
    lastread:=0;
    repeat
      lastread:=lastread+1;
      if lastread>incoming.nummail then begin
        lastread:=0;
        close(gfile);
        exit
      end;
      if not incoming.mail[lastread].read then begin
        readincoming (lastread);
        repeat
        write(^M^M^S'[CR/Next] [A/Again] [Q/Quit] [R/Reply] [D/Delete] ');
        if urec.level>=configset.sysopleve then write(^S'[E/Edit Sender] ');
        writestr(^S':*');
        if input='' then input:='N';
        if match(input,'R') then autoreply else if match(input,'A') then readincoming(lastread)
        else if match(input,'D') then begin
        deletemail(incoming,lastread);
        lastread:=lastread-1;
        input:='N';
        end else  if (match(input,'E') and (urec.level>=configset.sysopleve)) then editmailuser else
        if match(input,'Q') then begin close(gfile); exit; end;
        until (match(input,'N')) or hungupon;
      end
    until hungupon;
    close(gfile);
  end;

  procedure deleteincoming;
  var n:integer;
  begin
    if checklastread then begin
      n:=getmsgnumber (incoming,'delete');
      if n=0 then exit;
      lastread:=n
    end;
    deletemail (incoming,lastread);
    lastread:=lastread-1
  end;

  procedure killoutgoing;
  var n:integer;
  begin
    n:=getmsgnumber (outgoing,'kill');
    if n<>0 then deletemail (outgoing,n)
  end;

  procedure autoreply;
  var n:integer;
  begin
    if checklastread then begin
      n:=getmsgnumber (incoming,'reply to');
      if n=0 then exit;
      lastread:=n
    end;
    with incoming.mail[lastread] do
      sendmailto (sentby,anon);
    readcatalogs
  end;

  procedure viewoutgoing;
  var n:integer;
  begin
    n:=getmsgnumber (outgoing,'view');
    if n=0 then exit;
    readit (outgoing.mail[n])
  end;

  procedure showinfos;
  var n,info:integer;
  begin
    if checklastread then begin
      n:=getmsgnumber (incoming,'delete');
      if n=0 then exit;
      lastread:=n
    end;
    writestr('Which infoform to view [1-5]: [1]:*');
    if input='' then input:='1';
    info:=valu(input);
    if (info>0) and (info<6) then
    showinfoforms (incoming.mail[lastread].sentby,info)
  end;

  procedure editmailuser;
  var n:integer;
      m:mstr;
  begin
    if checklastread then begin
      n:=getmsgnumber (incoming,'edit the sender');
      if n=0 then exit;
      lastread:=n
    end;
    m:=incoming.mail[lastread].sentby;
    n:=lookupuser (m);
    if n=0 then begin
      writeln (^B^R'User ',m,' not found!');
      exit
    end;
    edituser (n)
  end;

  procedure writecurmsg;
  var b:boolean;
  begin
    b:=checklastread;
    write (^B^M'Current msg: ');
    if lastread=0
      then writeln ('None')
      else with incoming.mail[lastread] do
        writeln ('#',lastread,': ',title,' sent by ',sentby)
  end;

  procedure showannouncement (un:integer);
  var u:userrec;
  begin
    seek (ufile,un);
    read (ufile,u);
    if u.emailannounce>0 then begin
      writehdr (u.handle+'''s Announcement');
      printtext (u.emailannounce)
    end
  end;

  procedure copymsg (var m:mailrec; un:integer);
  var me:message;
      line:integer;
      b:boolean;
  begin
    me.anon:=m.anon;
    reloadtext (m.line,me);
    me.sendto:='All';
    me.title:='Was from '+m.sentby;
    showannouncement (un);
    writestr ('Add a prologue (A to abort)? *');
    if match(input,'a') then exit;
    if yes then b:=reedit (me,true);
    line:=maketext (me);
    addmail (un,line,me);
    readcatalogs
  end;

  procedure copymail;
  var n,un,line:integer;
  begin
    if checklastread then begin
      n:=getmsgnumber (incoming,'copy');
      if n=0 then exit;
      lastread:=n
    end;
    n:=lastread;
    writestr ('User to copy it to:');
    if length(input)=0 then exit;
    un:=lookupuser (input);
    if un=0 then exit;
    copymsg (incoming.mail[n],un)
  end;

  procedure forwardmail;
  var n,un:integer;
  begin
    if checklastread then begin
      n:=getmsgnumber (incoming,'forward');
      if n=0 then exit;
      lastread:=n
    end;
    n:=lastread;
    writestr ('User to forward it to:');
    if length(input)=0 then exit;
    un:=lookupuser (input);
    if un=0 then exit;
    copymsg (incoming.mail[n],un);
    deletemail (incoming,n)
  end;

  const groupclassstr:array [groupclass] of string[8]=
          ('Public','Private','Personal');

  procedure opengfile;
  begin
  close(gfile);
    assign (gfile,'groups');
    reset (gfile);
    if ioresult<>0 then begin
      close (gfile);
      rewrite (gfile)
    end
  end;

  procedure seekgfile (n:integer);
  begin
    seek (gfile,n-1)
  end;

  function ismember (var g:grouprec; n:integer):boolean;
  var cnt:integer;
  begin
    ismember:=true;
    for cnt:=1 to g.nummembers do
      if g.members[cnt]=n then exit;
    ismember:=false
  end;

  function groupaccess (var g:grouprec):boolean;
  begin
    if issysop then begin
      groupaccess:=true;
      exit
    end;
    groupaccess:=false;
    case g.class of
      publicgroup:groupaccess:=true;
      personalgroup:groupaccess:=g.creator=unum;
      privategroup:groupaccess:=ismember (g,unum)
    end
  end;

  function lookupgroup (nm:mstr):integer;
  var cnt:integer;
      g:grouprec;
  begin
    lookupgroup:=0;
    seekgfile (1);
    for cnt:=1 to filesize(gfile) do begin
      read (gfile,g);
      if groupaccess(g)
        then if match(g.name,nm)
          then begin
            lookupgroup:=cnt;
            exit
          end
    end
  end;

  procedure listgroups;
  var g:grouprec;
      cnt:integer;
  begin
    writestr (^M'Name                          Class'^M);
    if break then exit;
    seekgfile (1);
    for cnt:=1 to filesize(gfile) do begin
      read (gfile,g);
      if groupaccess(g) then begin
        tab (g.name,30);
        writeln (groupclassstr[g.class]);
        if break then exit
      end
    end
  end;

  function getgroupclass:groupclass;
  var k:char;
  begin
    repeat
      input[1]:=#0;
      writestr ('Group class p(U)blic, p(R)ivate, p(E)rsonal:');
      k:=upcase(input[1]);
      if k in ['U','R','E'] then begin
        case k of
          'U':getgroupclass:=publicgroup;
          'R':getgroupclass:=privategroup;
          'E':getgroupclass:=personalgroup
        end;
        exit
      end
    until hungupon;
    getgroupclass:=publicgroup
  end;

  procedure addmember (var g:grouprec; n:integer);
  begin
    if ismember (g,n) then begin
      writestr ('That person is already a member!');
      exit
    end;
    if g.nummembers=maxgroupsize then begin
      writestr ('Sorry, group is full!');
      exit
    end;
    g.nummembers:=g.nummembers+1;
    g.members[g.nummembers]:=n
  end;

  procedure addgroup;
  var g:grouprec;
      un:integer;
  begin
    writestr ('Group name:');
    if (length(input)=0) or (input='?') then exit;
    g.name:=input;
    if lookupgroup (g.name)<>0 then begin
      writestr (^M'Group already exists!');
      exit
    end;
    g.class:=getgroupclass;
    g.creator:=unum;
    g.nummembers:=0;
    writestr ('Include yourself in the group? *');
    if yes then addmember (g,unum);
    writestr (^M'Enter names of members, CR when done'^M);
    repeat
      writestr ('Member:');
      if length(input)>0 then begin
        un:=lookupuser (input);
        if un=0
          then writestr ('User not found!')
          else addmember (g,un)
      end
    until hungupon or (length(input)=0) or (g.nummembers=maxgroupsize);
    seek (gfile,filesize (gfile));
    write (gfile,g);
    writestr (^M'Group created!');
    writelog (13,1,g.name)
  end;

  function maybecreategroup (nm:mstr):integer;
  begin
    writestr ('Create group '+nm+'? *');
    if yes then begin
      addtochain (nm);
      addgroup;
      maybecreategroup:=lookupgroup (nm)
    end else maybecreategroup:=0
  end;

  function getgroupnum:integer;
  var groupname:mstr;
      gn:integer;
      g:grouprec;
  begin
    getgroupnum:=0;
    groupname:=copy(input,2,255);
    repeat
      if length(groupname)=0 then begin
        writestr (^M'  Group name [?=list]:');
        if length(input)=0 then exit;
        if input[1]='/' then delete (input,1,1);
        if length(input)=0 then exit;
        groupname:=input
      end;
      if groupname='?' then begin
        listgroups;
        groupname:=''
      end
    until length(groupname)>0;
    gn:=lookupgroup (groupname);
    if gn=0 then begin
      writestr ('Group not found!');
      gn:=maybecreategroup (groupname);
      if gn=0 then exit
    end;
    seekgfile (gn);
    read (gfile,g);
    if not groupaccess(g)
      then writestr ('Sorry, you may not access that group!')
      else getgroupnum:=gn
  end;

  procedure sendmail;
  var g:grouprec;

    procedure sendit (showeach:boolean);
    var un,line,cnt:integer;
        me:message;

      procedure addit (n:integer);
      begin
        if n<>unum then begin
          if showeach then writeln (lookupuname(n));
          addmail (n,line,me)
        end else deletetext (line)
      end;

    begin
      if g.nummembers<1 then exit;
      writehdr ('Sending mail to '+g.name);
      line:=editor (me,true,true,g.name,'0');
      if line<0 then exit;
      addit (g.members[1]);
      if g.nummembers=1 then exit;
      writeln (^B^M);
      for cnt:=2 to g.nummembers do begin
        un:=g.members[cnt];
        if un<>unum then begin
          line:=maketext (me);
          if line<0 then begin
            writeln (cnt,' of ',g.nummembers,' completed.');
            exit
          end;
          addit (un)
        end
      end;
      readcatalogs
    end;

    procedure sendtogroup;
    var gn:integer;
    begin
      gn:=getgroupnum;
      if gn=0 then exit;
      seekgfile (gn);
      read (gfile,g);
      sendit (true)
    end;

    procedure sendtousers;
    var cnt,un:integer;
    begin
      g.name:=input;
      un:=lookupuser (g.name);
      if un=0 then begin
        writestr (^M'User not found.');
        exit
      end;
      g.nummembers:=1;
      g.members[1]:=un;
      cnt:=1;
      showannouncement (un);
      repeat
        writestr ('Carbon copy #'+strr(cnt)+' to:');
        if length(input)>0 then begin
          un:=lookupuser (input);
          if un=0
            then writestr (^M'User not found!'^M)
            else if ismember (g,un)
              then writestr (^M'User is already receiving a copy!')
              else begin
                cnt:=cnt+1;
                g.nummembers:=cnt;
                g.members[cnt]:=un;
                showannouncement (un)
              end
        end
      until (length(input)=0) or (cnt=maxgroupsize);
      sendit (g.nummembers>1)
    end;

  begin
    writestr ('User to send mail to [''/'' to send Group Mail ]:');
    if length(input)<>0
      then if input[1]='/'
        then sendtogroup
        else sendtousers
  end;

  procedure zippymail;
  var un:integer;
      me:message;
      l:integer;
  begin
    writestr ('Send mail to:');
    if length(input)=0 then exit;
    un:=lookupuser (input);
    if un=0 then begin
      writestr ('No such user!');
      exit
    end;
    l:=editor (me,false,false,input,'0');
    if l<0 then exit;
    me.title:='-----';
    me.anon:=false;
    addmail (un,l,me);
    readcatalogs
  end;

  {overlay} procedure sysopmail;

    function sysopreadnum (var n:integer):boolean;
    var m:mailrec;
        k:char;
        done:boolean;

      procedure showit;
      begin
        clearscr;
        writeln (^B^N^M'Number  '^S,n,
                     ^M'Sent by '^S,m.sentby,
                     ^M'Sent to '^S,lookupuname (m.sentto),
                     ^M'Sent on '^S,datestr(m.when),' at ',timestr(m.when),
                     ^M'Title:  '^S,m.title,^M);
        printtext (m.line);
      end;

      procedure changen (m:integer);
      var r2:integer;
      begin
        r2:=filesize(mfile)-1;
        if (m<1) or (m>r2) then begin
          writestr ('Continue scan at [1-'+strr(r2)+']:');
          m:=valu(input)
        end;
        if (m>=1) and (m<=r2) then begin
          n:=m-1;
          done:=true
        end
      end;

    var q:integer;
    begin
      sysopreadnum:=false;
      seek (mfile,n);
      read (mfile,m);
      showit;
      repeat
        done:=false;
        q:=menu ('E-Mail Scan','ESCAN','QSERDNAC_#');
        if q<0
          then changen (-q)
          else case q of
            1:sysopreadnum:=true;
            2:sendmail;
            3:edituser(lookupuser(m.sentby));
            4:edituser(m.sentto);
            5:delmail(n);
            6,9:done:=true;
            7:showit;
            8:changen (0);
          end
      until (q=1) or done or hungupon
    end;

    procedure someoneelse;
    var t,last:integer;
    begin
      writestr (^M'User name to look at:');
      if (length(input)=0) or hu