ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/BEEHIVE/BBS/ROS341.ARC/ROSKOV.INC

Text File | 2000-06-30 | 16KB | 494 lines

{ ROSKOV.INC - Remote Operating System Kernel Overlayed Routines }

overlay procedure list(ch: char);
{ List a portion of the system message file }
  var
    line_count: integer;
    this: SysmPtr;
  begin
    this := SysmBase;
    while (this <> nil) and (this^.key <> ch) do
      this := this^.next;
    if this^.key = ch
      then
        begin
          writeln(USR);
          seek(sysm_file, succ(this^.loc));
          read(sysm_file, sysm_rec);
          line_count := 0;
          while (not brk) and (not EOF(sysm_file)) and (sysm_rec[1] <> ':') do
            begin
              writeln(USR, sysm_rec);
              read(sysm_file, sysm_rec);
              if user_rec.lines <> 99
                then
                  begin
                    line_count := succ(line_count);
                    if line_count mod user_rec.lines = 0
                      then pause
                  end
            end
        end
  end;

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_name(var fn: firstname; var ln: lastname);
{ Get user name }
  begin
    writeln(USR);
    repeat
      fn := trim(prompt('FIRST name', len_fn, 'ES'))
    until (not online) or (fn <> '');
    if fn = 'SYSOP'
      then ln := ''
      else
        repeat
          ln := trim(prompt(' LAST name', len_ln, 'ES'))
        until (not online) or (ln <> '')
  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 := 1;
    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: 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 := trim(prompt('Password (will NOT display as you type)', len_pw, 'S'));
        i := length(trial_pw);
        if (i < 4) or (i > len_pw)
          then writeln(USR, 'Length must be 4-', len_pw, ' characters.');
      until (not online) or ((4 <= i) and (i <= len_pw));
      user_rec.pw := trim(prompt(' Please enter it again for verification', len_pw, 'S'));
      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
    user_rec.nulls := strint(prompt('How many nulls do you need [0-9]?', 1, 'AES'))
  end;

overlay function mesg_start(pr: StrPr): 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, 1) + '-' + intstr(hi, 1) + ']?', 5, 'E'));
    if (i < lo) or (i > hi)
      then
        begin
          i := succ(user_rec.lasthi);
          writeln(USR, 'Starting after last high message (# ', user_rec.lasthi, ')...')
        end;
    mesg_start := i
  end;

overlay procedure mesg_header_list(loc: integer; var first_line, last_line: integer);
{ Display message header }
  var
    to_fn, fr_fn: firstname;
    to_ln, fr_ln: lastname;
    str: StrTAD;
    temp_user_rec: user_list;
    this: AreaPtr;
    AreaHere: Str10;
  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
              GetRec(DatF, user_to, temp_user_rec);
              to_fn := temp_user_rec.fn;
              to_ln := temp_user_rec.ln
            end;
        if user_from = user_loc
          then
            begin
              fr_fn := user_rec.fn;
              fr_ln := user_rec.ln
            end
          else
            begin
              GetRec(DatF, user_from, temp_user_rec);
              fr_fn := temp_user_rec.fn;
              fr_ln := temp_user_rec.ln
            end;
        str := FormTAD(date);
        this := AreaBase;
        while (area <> this^.Area) and (this <> nil) do
          this := this^.next;
          if (area = this^.Area)
            then
               AreaHere := this^.AreaName;
        writeln(USR);
        writeln(USR, AreaHere, ': ');
        case status of
          deleted: write(USR, 'Deleted');
          read:    write(USR, 'Read');
          private: write(USR, 'Private');
          public:  write(USR, 'Public')
        end;
        writeln(USR, ' message # ', num, ' 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
              writeln(AuditFile);
              write(AuditFile, AreaHere, ': ');
              case status of
                deleted: write(AuditFile, 'Deleted');
                read:    write(AuditFile, 'Read');
                private: write(AuditFile, 'Private');
                public:  write(AuditFile, 'Public')
              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)
            end;
        first_line := st_rec;
        last_line := size
      end
  end;

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;

overlay procedure mesg_build_index(mesg_area: byte);
{ Scan summary file and build message index list.  Public messages are tied
  to the current message area.  Private and authored messages are independent
  of 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;
    seek(summ_file, 1);
    while not EOF(summ_file) do
      with summ_rec do
        begin
          read(summ_file, summ_rec);
          if (status = public) and (area = mesg_area)
            then
              begin                         { Public message }
                msg_all := succ(msg_all);
                mesg_insert(0)
              end
          else if (status <> deleted) and (user_loc = user_to)
            then
              begin                         { Private message }
                msg_ind := succ(msg_ind);
                mesg_insert(1)
              end
          else if (status <> deleted) and (user_loc = user_from)
            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;
    summ_rec.user_from := 0
  end;

overlay procedure mesg_directory;
{ Display directory of messages }
  const
    col_width = 6;
  var
    hi, col_count, col_limit: integer;
  begin
    col_limit := max(1, user_rec.columns div col_width);
    if MesgBase = nil
      then hi := 0
      else hi := MesgLast^.MesgNo;
    writeln(USR, 'High message now  : ', hi);
    writeln(USR, 'Public messages   : ', msg_all);
    writeln(USR);
    if msg_ind = 0
      then writeln(USR, user_rec.fn, ', no messages for you at this time.')
      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
  end;

overlay procedure ReadDir(var entries, space_used: integer; var first: FilePtr);
{ Create an alphabetized list of files in the current file area }
  var
    i, j, off: integer;
    this: FilePtr;
    searchblk: FileBlock;                 { Buffer to define search params }
    answerblk: array[0..3] of FileBlock;  { Buffer to receive file names }
  begin
    new_dir := TRUE;
    space_used := 0;
    while first <> nil do                 { Clean out any old directory list }
      begin
        this := first;
        first := first^.Next;             { Go to next on chain }
        dispose(this)                     { Reclaim space }
      end;
    DirEntries := 0;
    with searchblk do
      begin
        drive := 0;
        for i := 1 to 11 do
          fname[i] := ord('?');
        extent := ord('?');
        s1     := ord('?');
        s2     := ord('?');
        reccount := 0;
        for i := 16 to 31 do
          map[i] := 0
      end;
    SetSect(SetDrv, SetUsr);
    BDOS(setdma, addr(answerblk));
    off := BDOS(findfirst, addr(searchblk));
    while off <> 255 do
      begin
        with answerblk[off] do
          { Non-system or sysop and not creating system directory? }
          if (($80 and ord(fname[10])) = 0) or
             ((user_rec.access >= 250) and (mode <> sysop_mode))
            then InsertFile(fname, 0, reccount + (extent + (s2 shl 5)) shl 7,
                            entries, space_used, first);
        off := BDOS(findnext, addr(searchblk))
      end;
    BDOS(setdma, fcb);                    { Restore DMA buffer }
    if user_rec.access >= 250
      then free_space := diskfree;
    SetSect(HomDrv, HomUsr)
  end;

overlay procedure LibReadDir(var entries, space_used: integer; var first: FilePtr);
{ Read library directory }
  var
    i, off: integer;
    LibBlock: array[0..3] of EntryBlock;
  begin
    SetSect(SetDrv, SetUsr);
    Assign(libr_file, LibReq);
    {$I-} Reset(libr_file) {$I+};
    if IOresult = 0
      then
        begin
          {$I-} blockread(libr_file, LibBlock, 1) {$I+};
          in_library := (IOresult = 0);
          i := 1;
          while in_library and (i < 11) do
            if LibBlock[0].fname[i] = $20
              then i := succ(i)
              else in_library := FALSE;
          in_library := in_library and (LibBlock[0].status = 0);
          if in_library
            then
              begin
                new_dir := TRUE;
                space_used := 0;
                LibEntries := 0;
                for i := 1 to pred(LibBlock[0].fsize shl 2) do
                  begin
                    off := i mod 4;
                    if off = 0
                      then blockread(libr_file, LibBlock, 1);
                    with LibBlock[off] do
                      if status < $FE
                        then InsertFile(fname, index, fsize, entries, space_used, first)
                  end
              end
        end;
    SetSect(HomDrv, HomUsr)
  end;

overlay function greg_to_jul(day, mon, yr: integer): real;
{ Convert from Gregorian date to Julian }
  var
    i: integer;
  begin
    i := (mon - 14) div 12;
    greg_to_jul := day - 32075 + 367 * (mon - 2 - 12 * i) div 12 -
                   3 * (yr + 6800 + i) div 400 + 365.25 * (yr + 6700 + i)
  end;