GEMini Atari/GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso/files/bbs/turbobbs/mailsys.inc

Text File | 1985-08-23 | 18KB | 694 lines

const
  numsects = 9;
  sectchar = '9';
  maxlength = 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[0..numsects] of person;
  messtext = array[1..24] of line;

const
  sect : sectname = ('Section 0: All',
                     'Section 1: General',
                     'Section 2: Ohio Scientific',
                     'Section 3: Kaypro, CP/M',
                     'Section 4: Buy and Sell',
                     'Section 5: 6502',
                     'Section 6: Turbo Pascal',
                     'Section 7: C',
                     'Section 8: CompuServe',
                     'Section 9: 6809');
  maxmess = 52;   { <-- Maximum number of messages - this limit due to CP/M
                    maximum directory size of 64 files on Kaypro.}

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

function namemess(number: integer): name;

  var
    filename: name;

  begin
    str((10000 + number):6, filename);
    namemess := '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 < 5))
                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;
    assign(messagefile, 'MESSAGES.BBS');
    reset(messagefile);
    repeat
      count := count + 1;
      read(messagefile, messtable[count]);
    until (count = maxmess) or eof(messagefile);
    close(messagefile);
    unload;
    nextmess := messtable[count].number + 1;
    messopen := true;
    status;
  end;

function findmessage(x: integer): byte;

  var
    loop: byte;

  begin
    loop := 0;
    repeat
      loop := loop + 1;
    until (loop >= count) or (messtable[loop].number >= x);
    if messtable[loop].number = x
      then findmessage := loop
      else findmessage := 0;
  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';
      stringout(' to: ' + temp);
      if recved then lineout(' (X)') else lineout(space);
      stringout('Subj: ' + subject);
      if clockin then stringout('  Time: ' + date);
      if sectsin then stringout('  ' + sect[section]);
      lineout(space);
    end;
  end;

procedure destroy(tabloc: byte);

  var
    loop: byte;

  begin
    if tabloc > 1 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));
      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;
    tempcs: name;

  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);
          tempcs := cs;
          cs := cr + lf;
          readfile(tabloc);
          cs := tempcs;
        end;
  end;

procedure delmessage(x: integer);

  var
    tabloc: byte;

  begin;
    tabloc := findmessage(x);
    if cts then begin
      if tabloc > 1 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 getnumber(prompt: line): integer;

  var
    temp: name;
    code: integer;
    messnum: integer;

  begin
    repeat
      code := 0;
      temp := getinput(prompt + 'which number? ', 14, echo);
      if temp = '*' then messnum := lastmess+1 else val(temp, messnum, code);
      if (code=0) and (messnum >= nextmess)
        then lineout('Message number too high.');
    until (temp = '') or ((code = 0) and (messnum < nextmess)) or not cts;
    if (temp = '') or not cts then getnumber := 0 else getnumber := messnum;
  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 begin
      delmessage(getnumber('Delete: '));
    end;
  end;

procedure quickscan;

  var
    loop: byte;
    first: integer;

  begin
    if cts then begin
      first := getnumber('Start at ');
      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;

procedure readind;

  var
   messnum: integer;
   tabloc : byte;

  begin
    repeat
      messnum := getnumber('Read (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') 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 getfirst: byte;

  var
    startmess, test : integer;
    temp            : name;
    prompt          : line;
    loop            : byte;

  begin
    repeat
      prompt := 'Start at which message (? for stats, * for new)? ';
      temp := getinput(prompt, 14, echo);
      val(temp, startmess, test);
      if temp = '?' then status;
      if temp = '*' then startmess := lastmess + 1;
    until (temp = '*') or ((test = 0) and (startmess < nextmess)) or not cts;
    loop := 0;
    repeat loop := loop + 1;
      until (messtable[loop].number >= startmess) or (loop = count);
    getfirst := loop;
  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;
          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;
          messagesearch(first, 0, tonum, 0);
        end;
    end;
  end;

procedure readsect;

  var
    sectnum, first: byte;
    inch: char;

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

procedure readmenu;

  begin
    if cts then begin
      clearsc;
      lineout('Read Menu:');
      lineout(cr + lf + '[A]ll messages;');
      lineout('[I]ndividual;');
      lineout('[F]rom a certain user;');
      lineout('[T]o a certain user;');
      if sectsin then lineout('by [S]ection number;');
      lineout(cr + lf + 'Hint: Use A* to read new messages since last call.')
    end;
  end;

procedure receive;

  var
    uchar: char;

  begin
    if cts then begin
      if not expert then readmenu;
      repeat
        uchar := getcap('Read mode: (A,I,F,T,S, or ? for menu)? ');
        if uchar = '?' then 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: 24 lines of 80 chars max.');
      lineout('An empty line ends entry. "." at start of line forces new line.');
      lineout(space);
      if linenum < 24 then repeat
        linenum := linenum + 1;
        str(linenum:2, temp);
        stringout(temp + ': ');
        block[linenum] := inputstring(echo);
      until (linenum = 24) 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;
      code: integer;
      x   : integer;

    begin
      repeat
        str(linenum:2, temp);
        temp := getinput(' Which line? (1 - ' + temp + ')? ', 14, echo);
        val(temp, x, code);
      until ((x in [1..linenum]) and (code=0)) or (temp='') or not cts;
      if (temp='') or not cts then whichline := 0 else whichline := x;
    end;

  procedure newheader(var entry: messages);

    var
      temp: char;
      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 := getcap('Which section (or "?" for list)? ');
          if temp = '?' then listsections;
          if temp in ['1'..sectchar] then entry.section := integer(temp)-integer('0');
        until (temp in  ['1'..sectchar]) 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;

  procedure editmenu;

    begin
      if cts then begin
        lineout(cr + lf + 'Edit menu:' + cr + lf);
        lineout('[A]bort;');
        lineout('[C]ontinue;');
        lineout('[D]elete line;');
        lineout('[E]dit a string in a line;');
        lineout('[L]ist from line;');
        lineout('[P]reformatted store (store with lines formatted as entered);');
        lineout('[R]eplace one entire line;');
        lineout('[S]tore Message in "No-Wrap" format.' + cr + lf);
      end;
    end;

  begin
    preformat := false;
    if cts then begin
      if access < 2 then lineout('This ID cannot enter messages: Read [W]elcome file.')
      else begin
        tabloc := count + 1;
        if tabloc > maxmess then lineout('No message space left.')
        else begin
          newheader(messtable[tabloc]);
          linenum := 0;
          compose(messbuff, linenum);
          if not expert then 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);
              '?': editmenu;
            end;
          until (inch = abort)
            or (inch = 'A')
            or (inch = 'S')
            or (inch = 'P')
            or not cts;
        end;  {2nd else}
      end;  {1st else}
    end; {if cts}
  end; {enter}
əəəəəəəəəə