{ PICSKMS1.INC - Pascal Integrated Communications System - Overlays }
{ 6/4/87 Ver. 1.6 Copyright 1987 by Les Archambault }

{ begin overlay .000 file here}

Overlay procedure send_time(size: integer; var mm, ss: integer);
{ Compute the file transfer time }
  var
    tr_time: real;
  begin
    tr_time := size * 23.5 / rate;          { Factor is empirically derived  }
    mm := trunc(tr_time);
    ss := round(60.0 * frac(tr_time))
  end;

Overlay procedure timer(var time_on, time_left: integer);
{ Compute the time on and the time remaining to the current user }
  var
    t: tad_array;
    give_extra:boolean;
  begin
    GetTAD(t); give_extra:=false;
    time_on := 60 * (t[2] - login_t[2]) + t[1] - login_t[1];
    if time_on < 0
      then time_on := time_on + 1440;
    time_left := user_rec.limit + extra_time - time_on - user_rec.time_today;
    if extra_time_sw then
      begin
        if extra_time_start<extra_time_stop then
          begin
            if (t[2]>extra_time_start) and (t[2]<extra_time_stop)
            then give_extra:=true;
          end
        else
          begin
            if (t[2]>extra_time_start) and (t[2]<extra_time_stop+24)
            then give_extra:=true;
            if (t[2]<extra_time_start) and (t[2]<extra_time_stop)
            then give_extra:=true;
          end;
        if give_extra then time_left:=time_left+extra_time_val;
      end;
  end;

Overlay Procedure Write_System_Status;
  var
    min,hr,i,x:integer;
    msg_count:real;
    bt:byte;
    timeout:boolean;
  begin
    gotoxy(1,3);
    writeln(version,'  ',ver_date); writeln;
    {$I-} seek(logr_file,0); {$I+}
    ok:=(ioresult=0);
    if OK then
      begin
        {$I-} read(logr_file,logr_rec); {$I+}
        OK:=(ioresult=0);
        if OK then writeln('Last Caller Number: ',logr_rec.user);
      end;
    If auto_macro then writeln('Automatic Macro:  ENABLED at ',
      auto_macro_start,':00.')
    else writeln('Automatic Macro:  OFF.');
    if restrict300 then writeln('300 Baud Callers:  RESTRICTED ',
      start_restrict300,':00 - ',end_restrict300,':00 Hours.')
    else writeln('300 Baud Callers:  OK.');
    if chat_ok then writeln('Chat Function:  ENABLED ',chatstart,
      ':00 - ',chatend,':00 Hours.')
    else writeln('Chat Function:  OFF');
    if limit_lines then writeln('Message Length:  LIMITED to ',max_msg_lines,' lines.')
    else writeln('Message Length:  NOT LIMITED.');
    if restrict_public then writeln('Public Messages:  RESTRICTED.')
    else writeln('Public Messages:  NOT RESTRICTED.');
    if extra_time_sw then writeln(extra_time_val,
      ' Minutes of extra time given from ',extra_time_start,
      ':00 to ',extra_time_stop,':00')
    else writeln('Extra time NOT active.');
    if (not clock) then
      begin
        hr:=trunc((hour_count/600.0)*(mhz/4.0));
        write('time  ',hr,':');
        min:=trunc(frac(hour_count/600)*(mhz/4.0)*60);
        if min<10 then write('0');
        writeln(min);
      end;
    writeln;
    writeln('^C to exit PICS,  ^L for Local Use.');
    i:=1; if ch_carck then x:=30 else x:=32000;
      repeat
        bt:=getbyte(1,timeout);
        if bt>0 then i:=x;   {key pressed remotely}
        i:=succ(i);
      until keypressed or (i>=x);
    clrscr;
  end;

Overlay Procedure Write_Config_File;
 var   ets,co,am,ll,r300,rp:char;
    begin
      Assign(Config_file,'CONFIG.BB#');
      Rewrite(config_file);
      if extra_time_sw then ets:='T' else ets:='F';
      if chat_ok then co:='T' else co:='F';
      if auto_macro then am:='T' else am:='F';
      if limit_lines then ll:='T' else ll:='F';
      if restrict300 then r300:='T' else r300:='F';
      if restrict_public then rp:='T' else rp:='F';
      write(config_file,maxfree_uplds,' ',maxfree_logs,' ',maxfree_mslimit,' ',
      maxfree_lines,' ',maxfree_abs,' ',extra_time_start,' ',extra_time_stop,' ',
      extra_time_val,' ',chatstart,' ',chatend,' ',sleepy_time,' ',max_tries,
      ' ',auto_macro_start,' ',max_msg_lines,' ',start_restrict300,' ',
      end_restrict300,' ',up_down_ratio,' ',val_time,' ',uval_time,' ',
      val_acc,' ',uval_acc,' ',val_days,' ',unv_days,' ',unr_days,' ',rea_days,' ');
      write(config_file,ets,co,am,ll,r300,rp);
      writeln(usr);
      writeln(usr,'Parameters Recorded.');
      close(config_file);
    end;

Overlay function FormTAD(t: tad_array): StrTAD;
{ Build printable string of current time and date }
  const
    day: array [0..6] of string[6] =
      ('Sun','Mon','Tues','Wednes','Thurs','Fri','Satur');
    month: array [1..12] of string[3] =
      ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
  var
    i: integer;
    line: StrTAD;

function zeller(day, month, year: integer): integer;
{ Compute the day of the week using Zeller's Congruence }
  var
    century: integer;
  begin
    if month > 2
      then month := month - 2
      else
        begin
          month := month + 10;
          year := pred(year)
        end;
    century := year div 100;
    year := year mod 100;
    zeller := (day - 1 + ((13 * month - 1) div 5) + (5 * year div 4) +
              century div 4 - 2 * century + 1) mod 7
  end;

  begin    {formTAD}
    if (t[1] in [0..59]) and (t[2] in [0..23]) and clock
      then line := intstr(t[2], 2) + ':' + intstr(t[1], 2)
      else line := '';
    for i:= 1 to length(line) do
      if line[i] = ' '
        then line[i]:= '0';
    if (t[3] in [1..31]) and (t[4] in [1..12]) and (t[5] in [0..99])
      then FormTAD :=
        line + '  ' +
        day[zeller(t[3], t[4], 1900 + t[5])] + 'day  ' +
        intstr(t[3], 2) + '-' + month[t[4]] + '-' + intstr(t[5], 2)
      else FormTAD := 'No Date'
  end;

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 (online)
          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 procedure mesg_insert(TypMsg: byte);
{ Insert message into linked list }
  var
    this: MesgPtr;
  begin
    new(this);
    if MesgBase = nil
      then MesgBase := this
      else MesgLast^.next := this;
    MesgLast := this;
    MesgLast^.MesgNo := summ_rec.num;
    MesgLast^.SummLoc := pred(FilePos(summ_file));
    MesgLast^.TypMsg := TypMsg;
    MesgLast^.next := nil
  end;

overlay Function get_section_name(mode:char):filename;
{ for file area sections}
   type
     section_rec=
       record
         sdrive:char;
         suser:integer;
         saccs:integer;
         confnum:integer;
         sname:filename;
         sdesc:strpr;
         mode:char;
       end;
   var
     sect_file:file of section_rec;
     sect_rec:section_rec;
     this:sectptr;
     line_count,conf_num:integer;
     work:filename;

     begin
       assign(sect_file,sect_name+ext);
       reset(sect_file);
       repeat
       this:=sectbase; writeln(usr);
       work:=prompt('Section name ',12,'ES?M');
       if (work=' ') and (mode<>'L') then
         begin
           work:=SectReq;
           writeln(usr,'Defaulting to: ',SectReq);
         end;
       if (work='?') then
         begin
           line_count:=2;
           writeln(usr,'Available file areas:');
           writeln(usr);
           while (not brk) and (this<>nil) do
             begin
               conf_num:=this^.sectconf;
               if (user_rec.access>=this^.sectaccs)
               or (test_bit(user_rec.conf_flags,conf_num)) then
                 begin
                   write(usr,pad(this^.sectname,14));
                   if (mode='D') or (mode='L') then
                     begin
                       seek(sect_file,this^.sectrec);
                       read(sect_file,sect_rec);
                       writeln(usr,sect_rec.sdesc);
                     end
                    else writeln(usr);
                 end;
               this:=this^.next;
               line_count:=succ(line_count);
               if line_count mod user_rec.lines=0 then pause;
             end;
           writeln(usr);
         end;
       this:=sectbase;
       while (this<>nil) and (this^.sectname<>work) do
       this:=this^.next;
       until (work=this^.sectname) or (brk) or (not online);
       close(sect_file);
       if work=this^.sectname then get_section_name:=work
       else get_section_name:='';
     end;

overlay procedure ArcSeek(offset:real; base:integer);
     { re-position the current pointer in the archive file }
  var b           : real;
      i, ofs, rec : integer;
      c           : byte;
      OK          : boolean;

procedure Read_Arc_Block;
{ read a block from the archive file }
  begin
    if EOF(arc_file) then endfile := TRUE
    else
      begin
        {$I-} BlockRead(arc_file, arcbuf, 1); {$I+}
        endfile:=(ioresult<>0);
      end;
    arcptr := 1
  end;

function Get_Arc_Ch : byte;
{ read 1 character from the archive file }
  begin
    if endfile then Get_Arc_Ch := 0
    else begin
      Get_Arc_Ch := arcbuf[arcptr];
      if arcptr = 128 then Read_Arc_Block
      else arcptr := arcptr + 1
    end
  end;

  begin  {arc_seek}
    setsect(SetDrv,SetUsr);
    b := offset + (unsigned_to_real(FilePos(arc_file)) - 1.0) * 128 + arcptr - 1.0;
    if ((b/128.0)>= -32768.0) and ((b/128.0) <=32767) then
      begin
        rec := Trunc(b / 128);
        ofs := Trunc(b - (Int(rec) * 128));  { Int converts to Real }
        {$I-} seek(arc_file, rec); {$I+}
        OK:=(ioresult=0);
        if OK then
          begin
            Read_Arc_Block;
            if not endfile then for i:=1 to ofs do c:=Get_Arc_Ch;
          end;
      end
    else endfile:=true;
  end;

overlay function Read_Arc_Hdr : boolean;
 { read a file header from the archive file }
 { FALSE = eof found; TRUE = header found }
  var name : fntype;
      try  : integer;
      bt : byte;

procedure Read_Arc_Block;
{ read a block from the archive file }
  begin
    if EOF(arc_file) then endfile := TRUE
    else
      begin
        {$I-} BlockRead(arc_file, arcbuf, 1); {$I+}
        endfile:=(ioresult<>0);
      end;
    arcptr := 1
  end;

function Get_Arc_Ch : byte;
{ read 1 character from the archive file }
  begin
    if endfile then Get_Arc_Ch := 0
    else begin
      Get_Arc_Ch := arcbuf[arcptr];
      if arcptr = 128 then Read_Arc_Block
      else arcptr := arcptr + 1
    end
  end;

procedure Fil_Arc_Rec(var buf; reclen : integer);
{ read a record from the archive file }
  var i : integer;
      b : array [1..128] of byte absolute buf;
  begin
    for i := 1 to reclen do b[i] := Get_Arc_Ch
  end;

  begin {read_arc_hdr}
    setsect(SetDrv,SetUsr);
    try :=10;
    OK:=true;
    if (not endfile) and (maxavail>=512) then
      begin
        bt:=0;
        while (bt<>26) and (not endfile) and OK do
          begin
            bt:=Get_Arc_Ch;
            if try = 0 then OK:=false;
            try := try - 1;
         end;
       hdrver := Get_Arc_Ch;
       if hdrver<0 then OK:=false;
       if hdrver = 0 then   { special end of file marker }
         begin
           Read_Arc_Hdr := FALSE;
           endfile:=true;
         end;
       if hdrver = 1 then
         begin
           Fil_Arc_Rec(hdr, sizeof(heads) - sizeof(long));
           hdrver := 2;
           hdr.length := hdr.size
         end
         else
         Fil_Arc_Rec(hdr, sizeof(heads));
       if OK then Read_Arc_Hdr := TRUE
       else Read_Arc_Hdr:=false;
      end
      else
        begin
          Read_Arc_Hdr:=false;
          if maxavail<512 then OK:=false;
        end;
  end;

{End of PICSKMS1.INC }