ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/TURBOPAS/TBBS22.LBR/TBBSMSG.IQC/TBBSMSG.INC

Text File | 2000-06-30 | 10KB | 396 lines

{ TBBSMSG.INC - Turbo Bulletin Board System message routines }

procedure mesg_find(num: integer);
begin
  MesgCurr := MesgBase;
  while (MesgCurr <> nil) and (MesgCurr^.MesgNo < num) do
    MesgCurr := MesgCurr^.next
end;

procedure mesg_insert;
var
  here: MesgPointer;
begin
  new(here);
  if MesgBase = nil
    then MesgBase := here
    else MesgLast^.next := here;
  MesgLast := here;
  MesgLast^.MesgNo := summ_rec.summ_num;
  MesgLast^.SummLoc := FilePos(summ_file) - 1;
  MesgLast^.next := nil
end;

procedure mesg_delete;
var
  here: MesgPointer;
begin
  if MesgCurr = MesgBase
    then MesgBase := MesgBase^.next
  else if MesgCurr <> nil
    then
      begin
        here := MesgBase;
        while here^.next <> MesgCurr do
          here := here^.next;
        here^.next := MesgCurr^.next;
        if MesgLast = MesgCurr
          then MesgLast := here;
        dispose(MesgCurr)
      end
end;

procedure mesg_print(last_line: integer);
{ Display message currently being edited }
var
  i: integer;
begin
  writeln;
  for i := 1 to last_line do
    writeln(i, ': ', mesg_array[i])
end;

procedure mesg_edit(last_line: integer);
{ Simple line-replacement 'editor' }
var
  i: integer;
  msg: message;
begin
  writeln;
  i := strint(prompt('Line number: ', 5, 'E'));
  if (1 <= i) and (i <= last_line)
    then
      begin
        writeln(i, ': ', mesg_array[i]);
        writeln('Enter new line (C/R for no change):');
        msg := prompt(intstr(i) + ': ', len_msg, 'EA');
        if msg <> ''
          then mesg_array[i] := msg;
      end
    else writeln('Line not found')
end;

procedure mesg_in(var last_line: integer);
{ Input message }
var
  msg: message;
begin
  msg := ' ';
  writeln;
  while (last_line <= Max_lines) and (msg <> '') and (not brk) do
    begin
      msg := prompt(intstr(last_line) + ': ', len_msg, 'EA');
      if msg <> ''
        then
          begin
            mesg_array[last_line] := msg;
            last_line := last_line + 1
          end
    end
end;

procedure mesg_save(to_num: integer; subj: subject; last_line: integer;
  var stop_msg: boolean);
{ Save message to disk }
var
  i, start: integer;
  file_time: tad_array;
  st: StdStr;
begin
  GetTAD(file_time);
  st := systad(file_time);
  start := filesize(mesg_file);
  seek(summ_file, 0);
  read(summ_file, summ_rec);
  with summ_rec do
    begin
      summ_num      := summ_num + 1;
      summ_date     := file_time;
      summ_from_num := user_loc;
      summ_to_num   := to_num;
      summ_subject  := subj;
      summ_st_rec   := start;
      summ_size     := last_line
    end;
  seek(summ_file, 0);
  write(summ_file, summ_rec);
  seek(summ_file, filesize(summ_file));
  write(summ_file, summ_rec);

  mesg_insert;

  seek(mesg_file, start);
  for i := 1 to last_line do
    begin
      mesg_rec.mesg_text := mesg_array[i];
      write(mesg_file, mesg_rec)
    end;

  Close(summ_file);          { in case user hangs up }
  Close(mesg_file);
  Reset(summ_file);
  Reset(mesg_file);

  writeln;
  writeln('Message ', summ_rec.summ_num, ' filed at ', st);
  stop_msg := TRUE
end;

procedure mesg_quit(var stop_msg: boolean);
{ Return to command mode }
begin
  writeln;
  writeln('Aborted.');
  stop_msg := TRUE
end;

procedure mesg_header_list(var start, last_line: integer);
{ Display message header }
var
  st: StdStr;
  to_fn, fr_fn: firstname;
  to_ln, fr_ln: lastname;
  user_rec: user_list;
begin
  seek(summ_file, MesgCurr^.SummLoc);
  read(summ_file, summ_rec);
  with summ_rec, user_rec do
    begin
      if summ_to_num = mesg_pub
        then
          begin
            to_fn := 'ALL';
            to_ln := ''
          end
      else if summ_to_num = user_loc
        then
          begin
            to_fn := fn;
            to_ln := ln
          end
        else
          begin
            GetRec(DatF, summ_to_num, user_rec);
            to_fn := user_firstname;
            to_ln := user_lastname
          end;
      if summ_from_num = user_loc
        then
          begin
            fr_fn := fn;
            fr_ln := ln
          end
        else
          begin
            GetRec(DatF, summ_from_num, user_rec);
            fr_fn := user_firstname;
            fr_ln := user_lastname
          end;
      st := systad(summ_date);
      writeln;
      writeln('Message number ', summ_num, ' entered ', st, '.');
      writeln('From: ', fr_fn, ' ', fr_ln);
      writeln('  To: ', to_fn, ' ', to_ln);
      writeln('  Re: ', summ_subject);
      start := summ_st_rec;
      last_line := summ_size
    end
end;

procedure mesg_text_list(start, last_line: integer);
var
  i: integer;
begin
  seek(mesg_file, start);
  for i := 1 to last_line do
    begin
      read(mesg_file, mesg_rec);
      writeln(mesg_rec.mesg_text)
    end;
  seek(summ_file, MesgCurr^.SummLoc);
  read(summ_file, summ_rec);
  if (user_loc = summ_rec.summ_from_num) or
     (user_loc = summ_rec.summ_to_num) or
     (fn = 'SYSOP')
    then if ask('Do you wish to ERASE this message')
      then
        begin
          summ_rec.summ_to_num := mesg_era;
          seek(summ_file, MesgCurr^.SummLoc);
          write(summ_file, summ_rec);
          mesg_delete;
          writeln('Erased.')
        end
      else writeln('Retained.')
end;

procedure mesg_enter(comment: boolean);
{ Enter a new message }
var
  stop_msg: boolean;
  last_line, to_loc: integer;
  st: StdStr;
  to_fn: firstname;
  to_ln: lastname;
  subj: subject;
begin
  repeat
    writeln;
    if (bbs_stat = 0) or (comment)
      then
        begin
          to_fn := 'SYSOP';
          writeln('To: ', to_fn)
        end
      else to_fn := prompt('To FIRST name (<RET> for ALL): ', len_fn, 'ES');
    if to_fn = ''
      then to_loc := mesg_pub
      else
        begin
          if to_fn = 'SYSOP'
            then to_ln := ''
            else to_ln := prompt('LAST name: ', len_ln, 'ES');
          to_loc := find_user(to_fn, to_ln);
          if to_loc = -1
            then
              begin
                writeln(to_fn, ' ', to_ln, ' not known on system.');
                to_loc := -2
              end
        end
  until to_loc >= -1;
  if bbs_stat = 0
    then
      begin
        subj := 'NEW USER';
        writeln('Subject: ', subj)
      end
    else subj := prompt('Subject: ', len_subj, 'ES');
  writeln;
  writeln('To re-enter command mode, enter empty line (C/R only).');
  writeln('Enter message (', Max_Lines, ' line limit):');
  last_line := 1;
  mesg_in(last_line);
  stop_msg := FALSE;
  repeat
    writeln;
    st := prompt('(L)ist, (E)dit, (C)ontinue, (S)ave, (Q)uit? ', 1, 'AES');
    case st[1] of
      'L': mesg_print(last_line - 1);
      'E': mesg_edit(last_line - 1);
      'C': mesg_in(last_line);
      'S': mesg_save(to_loc, subj, last_line - 1, stop_msg);
      'Q': mesg_quit(stop_msg);
      else writeln(st, '?')
    end
  until stop_msg
end;

function mesg_start(pr: StdStr): integer;
{ Get starting message number from user }
var
  i, lo, hi: integer;
begin
  if MesgBase = nil
    then
      begin
        lo := 0;
        hi := 0
      end
    else
      begin
        lo := MesgBase^.MesgNo;
        hi := MesgLast^.MesgNo
      end;
  i := strint(prompt(pr + ' [' + intstr(lo) + '-' + intstr(hi) + ']? ', 5, 'E'));
  if (i < lo) or (i > hi)
    then i := lo;
  mesg_start := i
end;

procedure mesg_quick_scan;
{ Print abbreviated summary of messages }
var
  private: boolean;
  sep: StdStr;
begin
  private := FALSE;
  mesg_find(mesg_start('Start'));
  writeln;
  while (MesgCurr <> nil) and (not brk) do
    begin
      seek(summ_file, MesgCurr^.SummLoc);
      read(summ_file, summ_rec);
      if summ_rec.summ_to_num = mesg_pub
        then sep := ': '
        else
          begin
            sep := '* ';
            private := TRUE
          end;
      writeln(summ_rec.summ_num, sep, summ_rec.summ_subject);
      MesgCurr := MesgCurr^.next
    end;
  if private
    then
      begin
        writeln;
        writeln('"*" indicates a private message.')
      end
end;

procedure mesg_summary;
{ Message summary }
var
  start, last_line: integer;
begin
  mesg_find(mesg_start('Start'));
  while (MesgCurr <> nil) and (not brk) do
    begin
      mesg_header_list(start, last_line);
      MesgCurr := MesgCurr^.next
    end
end;

procedure mesg_read;
{ Read message }
var
  i, start, last_line: integer;
begin
  i := mesg_start('Message');
  mesg_find(i);
  if MesgCurr^.MesgNo = i
    then
      begin
        mesg_header_list(start, last_line);
        mesg_text_list(start, last_line)
      end
    else writeln('Not found.')
end;

procedure mesg_build_index;
{ Scan summary file and build message index list }
begin
  msg_all := 0;
  msg_ind := 0;
  MesgBase := nil;
  seek(summ_file, 1);
  while not EOF(summ_file) do
    begin
      read(summ_file, summ_rec);
      if summ_rec.summ_to_num = mesg_pub                 { public message }
        then
          begin
            msg_all := succ(msg_all);
            mesg_insert
          end
      else if (summ_rec.summ_to_num = user_loc)          { private message }
          or ((summ_rec.summ_to_num <> mesg_era) and (fn = 'SYSOP'))
        then
          begin
            msg_ind := succ(msg_ind);
            mesg_insert
          end
    end
end;