Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB21.ZIP/MADTRB14.ZIP/MAILSYS.INC

Text File | 1985-10-05 | 16.9 KB | 656 lines

const
  numsects = 12;
  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: Ohio Scientific',
                     '3: CP/M',
                     '4: Buy and Sell',
                     '5: 6502',
                     '6: Turbo Pascal',
                     '7: C',
                     '8: CompuServe',
                     '9: 6809',
                     '10: Kaypro',
                     '11: MS-DOS',
                     '12: TurboBBS code');

  maxmess = 52;   { <-- Maximum number of messages - this limit due to CP/M
                    maximum directory size on Kaypro.}

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) + '.TXT';
  end;

procedure kill(x: integer);

  var
    victim: text;

  begin
    assign(victim, namemess(x));
    erase(victim);
  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);
    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;
    unload;
    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 cts then delmessage(getint(nextmess - 1, 0, 'Delete: which number? '));
  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;
    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 (Y/N/Quit)? ');
        if inch = 'Y' 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);
        unload;
        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;
          unload;
          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}