Oakland CPM Archive/oakcpm.iso/cpm/bbs/pics16.ark/PICS0A.INC

Text File | 1987-05-25 | 13.9 KB | 419 lines

{ PICS0A.INC - Pascal Integrated Communications System Overlays}
{ 5/25/87 VER. 1.6  Copyright 1987 by les archambault }

overlay function correct_fn(str: FileName): FileName;
{ Correct possible errors in file name }
  var
    i, j: integer;
  begin
    i := 1;                                 { Remove blanks and invalid characters }
    while i <= length(str) do
      if str[i] in [' ', '*', ',', ':', ';', '=', '?', '_']
        then delete(str, i, 1)
        else i := succ(i);
    while (str <> '') and (str[1] = '.') do { Remove leading '.' }
      delete(str, 1, 1);
    i := pos('.', str);                     { Remove redundant '.' }
    j := 1;
    while j <= length(str) do
      if (str[j] = '.') and (j > i)
        then delete(str, j, 1)
        else j := succ(j);
    i := pos('.', str);
    if i = 0                                { Ensure name has '.' }
      then
        begin
          str := copy(str, 1, 8);           { Ensure file name <= 8 characters }
          if length(str) > 0
            then str := str + '.'
        end
      else str := copy(str, 1, min(8, pred(i))) + '.' +
                  copy(str, succ(i), min(3, length(str) - i));
    correct_fn := str
  end;

overlay function compress_fn(name: FileName): FileName;
{ Strip hi bits and remove all blanks from file name }
  var
    i: integer;
  begin
    for i := 1 to length(name) do
      name[i] := chr($7F and ord(name[i]));
    i := pos(' ', name);
    while i > 0 do
      begin
        delete(name, i, 1);
        i := pos(' ', name)
      end;
    compress_fn := name
  end;

overlay procedure get_old_password(pr: StrPr; var valid: boolean);
{ Accept and validate old password.  Only 'Max_Tries' will be allowed. }
  var
    tries: integer;
  begin
    tries := 0;
    repeat
      valid := (user_rec.pw = prompt(pr, len_pw, 'S'));
      tries := succ(tries)
    until (not online) or valid or (tries > Max_Tries);
    if not valid
      then writeln(USR, 'Only ', Max_Tries, ' tries allowed.')
  end;

overlay procedure get_new_password;
{ Accept and validate new password. }
  var
    i,x: integer;
    trial_pw: password;
  begin
    writeln(USR);
    writeln(USR, 'Please select and enter a password of 4-', len_pw, ' characters');
    writeln(USR, 'to ensure that no one else uses your name on the system.');
    writeln(USR);
    repeat
      repeat
        trial_pw := prompt('Password (will NOT display as you type)', len_pw, 'SL');
        i := length(trial_pw);
        if (i < 4) or (i > len_pw)
          then writeln(USR, 'Length must be 4-', len_pw, ' characters.')
        else
          begin
            for x:=1 to length(trial_pw) do
              if (not(ord(trial_pw[x]) in [48..57])) and (not(ord(trial_pw[x]) in [65..90]))
                 then i:=0;
            if i=0 then writeln(usr,'Only characters A-Z and numbers 0-9 allowed.');
          end;
      until (not online) or ((4 <= i) and (i <= len_pw));
      user_rec.pw := prompt(' Please enter it again for verification', len_pw, 'SL');
      if user_rec.pw <> trial_pw
        then writeln(USR, 'No match.  Try again.')
    until (not online) or (user_rec.pw = trial_pw);
    writeln(USR);
    writeln(USR, 'Please remember your password.');
    writeln(USR, 'It will be required for all future calls.')
  end;

overlay procedure get_case;
{ Get case switch from user }
  begin
    user_rec.shift_lock := not ask('Can your terminal display lower case')
  end;

overlay procedure get_nulls;
{ Get nulls from user }
  begin
    if online then
    user_rec.nulls := strint(prompt('How many nulls do you need [0-9]?', 1, 'ES'))
  end;

overlay function mesg_start(pr: StrPr): integer;
{ Get starting message number from user }
  var
    i,last: integer;
  begin
    repeat
      writeln(usr); last:=user_rec.lasthi;
      i:= strint(prompt(pr +' (last mesg you read is '+intstr(last,1)+') '+
      ' [' + intstr(msg_lo, 1) + '-' + intstr(msg_hi, 1) + ']?',5,'E'));
      if (i <msg_lo) or (i >msg_hi)
        then Writeln(usr,'Invalid message number, try again.');
    until ((i>=msg_lo) and (i<=msg_hi)) or (not online);
   mesg_start := i
  end;

Overlay procedure mesg_header_list(loc:integer; var first_line,
  last_line:integer; var Fr_fn:firstname; var Fr_ln:lastname);
{ Display message header }
  var
    to_fn: firstname;
    to_ln: lastname;
    str: StrTAD;
    temp_user_rec: user_list;
    this: areaptr;
  begin
    seek(summ_file, loc);
    read(summ_file, summ_rec);
    with summ_rec do
      begin
        if user_to = 0
          then
            begin
              to_fn := 'ALL';
              to_ln := ''
            end
        else if user_to = user_loc
          then
            begin
              to_fn := user_rec.fn;
              to_ln := user_rec.ln
            end
          else
            begin
              if user_to<>-1 then
                begin
                  GetRec(DatF, user_to, temp_user_rec);
                  to_fn := temp_user_rec.fn;
                  to_ln := temp_user_rec.ln;
                end
              else
                begin
                  to_fn:='Deleted User';
                  to_ln:='';
                end;
            end;
        if user_from = user_loc
          then
            begin
              fr_fn := user_rec.fn;
              fr_ln := user_rec.ln
            end
          else
            begin
              if user_from<>-1 then
                begin
                  GetRec(DatF, user_from, temp_user_rec);
                  fr_fn := temp_user_rec.fn;
                  fr_ln := temp_user_rec.ln;
                end
              else
                begin
                  fr_fn:='Deleted User';
                  fr_ln:='';
                end;
            end;
        str := FormTAD(date);
        this:=areabase;
        while (this<>nil) and (this^.area<>area) do this:=this^.next;
        writeln(USR);
        if num_prev=255 then write(usr,'<P>');
        case status of
          deleted: write(USR, 'Deleted');
          read:    write(USR, 'Read');
          private: write(USR, 'Private');
          public:  write(USR, 'Public');
          restricted: write(usr,'Restricted');
        end;
     writeln(USR,' message # ',num,'    ',this^.areaname,
                 ' AREA ','   Entered ',str);
        writeln(USR, 'From: ', fr_fn, ' ', fr_ln);
        writeln(USR, '  To: ', to_fn, ' ', to_ln);
        writeln(USR, '  Re: ', subject);
        if audit_on
          then
            begin
              setsect(AudDrv,AudUsr);
              writeln(AuditFile);
              if num_prev=255 then write(auditfile,'<P>');
              case status of
                deleted: write(AuditFile, 'Deleted');
                read:    write(AuditFile, 'Read');
                private: write(AuditFile, 'Private');
                public:  write(AuditFile, 'Public');
                restricted: write(Auditfile,'Restricted');
              end;
              writeln(AuditFile, ' message # ', num, ' entered ', str);
              writeln(AuditFile, 'From: ', fr_fn, ' ', fr_ln);
              writeln(AuditFile, '  To: ', to_fn, ' ', to_ln);
              writeln(AuditFile, '  Re: ', subject);
              setsect(homdrv,homusr);
            end;
        first_line := st_rec;
        last_line := size
      end
  end;   {message header list}

overlay procedure mesg_delete;
{ Delete the current message }
  var
    this: MesgPtr;
  begin
    summ_rec.status := deleted;
    seek(summ_file, pred(FilePos(summ_file)));
    write(summ_file, summ_rec);
    this := MesgCurr;
    if MesgCurr = MesgBase
      then
        begin
          MesgCurr := MesgBase^.next;
          MesgBase := MesgBase^.next;
          dispose(this)
        end
    else if MesgCurr <> nil
      then
        begin
          MesgCurr := MesgBase;             { Find previous record }
          while MesgCurr^.next <> this do
            MesgCurr := MesgCurr^.next;
          MesgCurr^.next := this^.next;     { Make it point to next record }
          if MesgLast = this
            then MesgLast := MesgCurr;
          MesgCurr := MesgCurr^.next;
          dispose(this)
        end;
    writeln(USR, 'Message #', summ_rec.num, ' deleted.')
  end;  {mesg_delete}

overlay procedure mesg_build_index(mesg_area: byte);
{ Scan summary file and build message index list.  Messages are tied
  to the current message area.
  All messages are accessible in mesg_area #0 (SYSTEM). }
  var
    this: MesgPtr;
  begin
    while MesgBase <> nil do                { Delete old messages }
      begin
        this := MesgBase;
        MesgBase := MesgBase^.next;         { Go to next on list }
        dispose(this)                       { Reclaim space }
      end;
    msg_all := 0;
    msg_ind := 0;
    msg_aut := 0;
    msg_sys := 0;
    msg_hi:=0;
    msg_lo:=30000;
    seek(summ_file, 1);
    while not EOF(summ_file) do
      with summ_rec do
        begin
          read(summ_file, summ_rec);
          if ((status<>deleted) and (status<>restricted) and (area=mesg_area))
          or (mesg_area=0) then
            begin
              if msg_lo>num then msg_lo:=num;
              if num>msg_hi then msg_hi:=num;
            end;
          if (status=public) and ((area=mesg_area) or (mesg_area=0))  {Public message}
            then
            If user_loc=user_to then
              begin
                msg_ind:=succ(msg_ind);
                msg_all:=succ(msg_all);    {add to public count too}
                mesg_insert(1);
              end
            else
            If user_loc=user_from then
              begin
              msg_aut:=succ(msg_aut);
              msg_all:=succ(msg_all);
              mesg_insert(2);
              end
            else
              begin
                msg_all := succ(msg_all);
                mesg_insert(0)
              end
          else if (status <> deleted) and (user_loc = user_to)
                  and ((area=mesg_area) or (mesg_area=0))
            then
              begin                         { Private message }
                msg_ind := succ(msg_ind);
                mesg_insert(1)
              end
          else if (status <> deleted) and (user_loc = user_from)
                  and ((area=mesg_area) or (mesg_area=0))
            then
              begin                         { Author of message }
                msg_aut := succ(msg_aut);
                mesg_insert(2)
              end
          else if mesg_area = 0
            then
              begin                         { Sysop can view all messages }
                msg_sys := succ(msg_sys);
                mesg_insert(3)
              end
        end;
    if msg_lo>=29999 then msg_lo:=0;
    summ_rec.user_from := 0
  end;

overlay procedure mesg_directory;
{ Display directory of messages }

  var
    col_width, col_count, col_limit,conf_num: integer;
    this:areaptr;
    temstr:string[160];
    found:boolean;

  begin  {msg_directory}
    col_width:=6;
    col_limit := max(1, user_rec.columns div col_width);
    writeln(USR, 'Message numbers, this area  : ',msg_lo,'-',msg_hi);
    writeln(USR, 'Public messages, this area  : ', msg_all);
    writeln(USR);
    if msg_ind = 0
      then writeln(USR, user_rec.fn, ', no messages for you in this area.')
      else
        begin
          writeln(USR, user_rec.fn, ', the following messages are addressed to you:');
          col_count := 0;
          MesgCurr := MesgBase;
          while (not brk) and (MesgCurr <> nil) do
            begin
              if MesgCurr^.TypMsg = 1
                then
                  begin
                    write(USR, MesgCurr^.MesgNo:col_width);
                    col_count := succ(col_count);
                    if (0 = col_count mod col_limit)
                      then writeln(USR)
                  end;
              MesgCurr := MesgCurr^.next
            end;
          writeln(USR)
        end;
    if msg_aut > 0
      then
        begin
          writeln(USR, user_rec.fn, ', the following messages were sent by you:');
          col_count := 0;
          MesgCurr := MesgBase;
          while (not brk) and (MesgCurr <> nil) do
            begin
              if MesgCurr^.TypMsg = 2
                then
                  begin
                    write(USR, MesgCurr^.MesgNo:col_width);
                    col_count := succ(col_count);
                    if (0 = col_count mod col_limit)
                      then writeln(USR)
                  end;
              MesgCurr := MesgCurr^.next
            end;
          writeln(USR);
        end;
    Seek(summ_file,1);                  {look for msgs in other areas}
    col_count:=0;  col_width:=12; temstr:=''; Writeln(usr);
    col_limit:=max(1,user_rec.columns div col_width);
    found:=false;
    While not EOF(summ_file) do
      with summ_rec do
        begin
        read(summ_file,summ_rec);
        if (status<>deleted) and (area<>areaset) and (user_loc=user_to) then
          begin
            this:=areabase;
            while (this<>nil) and (this^.area<>area) do this:=this^.next;
            conf_num:=this^.Areaconf;
            if (pos(this^.areaname,temstr)=0) and (this<>nil)
                and ((user_rec.access>=this^.areaaccs)
                or (test_bit(user_rec.conf_flags,conf_num))) then
              begin
                found:=true;
                Write(usr,this^.areaname:col_width);
                col_count:=succ(col_count); temstr:=temstr+this^.areaname;
                if (0=col_count mod col_limit) then writeln(usr);
              end;
          end;
        end;   {reading summary file}
    writeln(usr);
    if found then Writeln(usr,user_rec.fn,', Above are other Areas with messages for you.');
    writeln(usr);
  end;

{END OF PICS0A.INC }