{ PICS2J.INC - Pascal Integrated Communications System }
{ 5/25/87 vers 1.6 Copyright 1987 by Les Archambault}

overlay  procedure delete_file;
  { Delete file from disk }
    var
      DelName: FileName;
      DelFile: file;
    begin
      if (not in_library) and (not in_arc) and ((user_rec.access>=250)
      or (not remote_copy)) then
       begin
         DelName := correct_fn(prompt('Name of file to delete', 12, 'ES'));
         if (DelName <> '') and (delname<>' ') then
           begin
             Assign(DelFile, DelName);
             SetSect(SetDrv, SetUsr);
             {$I-} Reset(DelFile) {$I+};             { Ensure file exists }
             OK := (IOresult = 0);
             if OK then
               begin
                 if ask('Are you sure') then
                   begin
                     Close(DelFile);
                     Erase(DelFile);
                     writeln(USR, DelName, ' deleted.')
                   end
               end
             else writeln(USR, DelName, ' not found.');
           end;
         SetSect(HomDrv, HomUsr);
         ReadDir(direntries,dirspace,dirbase);
       end
      else
      if in_library or in_arc then Writeln(usr,'Deleting not allowed.');
    end;

 overlay procedure copy_file;
  { Copy file from one file area to another }
    var
      DstDrv, DstUsr, Remaining: integer;
      DstSect, SrcName: FileName;
      SrcFile, DstFile: file;

    procedure do_copy;
      const
        BufSize = 4;
        BufBytSize = 512;                     { BufSize * 128 }
      var
        NoOfRecsToRead: Integer;
        Buffer: array[1..BufBytSize] of Byte;
      begin
        while OK and (Remaining > 0) do
          begin
            if BufSize <= Remaining
              then NoOfRecsToRead := BufSize
              else NoOfRecsToRead := Remaining;
            SetSect(SetDrv, SetUsr);
            {$I-} BlockRead(SrcFile, Buffer, NoOfRecsToRead) {$I+};
            OK := (IOresult = 0);
            if OK
              then
                begin
                  SetSect(DstDrv, DstUsr);
                  {$I-} BlockWrite(DstFile, Buffer, NoOfRecsToRead) {$I+};
                  OK := (IOresult = 0);
                  if OK
                    then Remaining := Remaining - NoOfRecsToRead
                    else writeln(USR, 'Write failed.')
                end
              else writeln(USR, 'Read failed.')
          end
      end;

    begin { copy_file }
    if (not in_library) and (not in_arc) and ((user_rec.access>=250)
    or (not remote_copy)) then
     begin
      SrcName := Correct_fn(prompt('Name of file to copy', 12, 'ES'));
      if (SrcName='') or (SrcName=' ') then OK:=False else OK:=true;
      if OK then
        begin
          Assign(SrcFile, SrcName);
          SetSect(SetDrv, SetUsr);
          {$I-} Reset(SrcFile) {$I+};           { Ensure file exists }
          OK := (IOresult = 0);
        end;
      if OK
        then
          begin
            Remaining := FileSize(SrcFile);
            SetSect(homdrv,homusr);
            DstSect := get_section_name('L');
            SetSect(setdrv,setusr);
            FindSect(DstSect, DstDrv, DstUsr, OK);
            if OK
              then
                begin
                  Assign(DstFile, SrcName);
                  SetSect(DstDrv, DstUsr);
                  {$I-} Reset(DstFile) {$I+};    { Ensure file doesn't already exist }
                  OK := (IOresult <> 0);
                  if OK
                    then
                      begin
                        {$I-} Rewrite(DstFile) {$I+};
                        OK := (IOresult = 0);
                          if OK
                            then
                              begin
                                do_copy;
                                SetSect(DstDrv, DstUsr);
                                {$I-} Close(DstFile) {$I+};
                                OK := OK and (IOresult = 0);
                                SetSect(SetDrv, SetUsr);
                                Close(SrcFile);
                                if OK
                                  then
                                    begin
                                      writeln(USR, SrcName, ' successfully copied.');
                                      if ask('Delete original file')
                                        then
                                          begin
                                            Erase(SrcFile);
                                            writeln(USR, 'Original file deleted.')
                                          end
                                        else writeln(USR, 'Original file retained.')
                                    end
                                  else
                                    begin
                                      setsect(dstdrv,dstusr);
                                      close(dstfile);
                                      Erase(DstFile);
                                      writeln(USR, 'Copy failed.  Partial file deleted.')
                                    end
                              end
                            else writeln(USR, 'Cannot create file in destination area.')
                      end
                    else writeln(usr,'File already exists in destination area.')
                end
              else writeln(USR, 'Destination section ', DstSect, ' not found.')
          end
        else writeln(USR, 'File ', SrcName, ' not found.');
      SetSect(HomDrv, HomUsr);
      ReadDir(direntries,dirspace,dirbase);
     end
     else
     if in_library or in_arc then Writeln(usr,'Copying not allowed.');
    end;

   overlay Procedure Rename_file;
      var
      oldname,newname:filename;
      newfile,oldfile:file;

    Begin
    if (not in_library) and (not in_arc) and ((user_rec.access>=250)
    or (not remote_copy)) then
     begin
      Writeln(usr);
      oldname:=correct_fn(prompt('Old File Name',12,'ES'));
      If (oldname<>'') and (oldname<>' ') then
        Begin
          assign(oldfile,oldname);
          setsect(setdrv,setusr);
          {$I-} reset(oldfile); {$I+}
          ok:=(ioresult=0);
          setsect(homdrv,homusr);
          if ok then
            begin
              newname:=correct_fn(prompt('New File Name',12,'ES'));
              If (newname<>'') and (newname<>' ') then
                begin
                  assign(newfile,newname);
                  setsect(setdrv,setusr);
                  {$I-} Reset(newfile); {$I+}
                  ok:=(ioresult<>0);
                  if ok then
                    begin
                      rename(oldfile,newname);
                      writeln(usr,'File Renamed');
                    end
                  else
                    begin
                      writeln(usr,newname,' already exists.');
                      close(newfile);
                      setsect(homdrv,homusr);
                    end;
                end
            else
            writeln(usr,oldname,' not found.');
            end;
        end;
      setsect(homdrv,homusr);
      ReadDir(direntries,dirspace,dirbase);
     end
     else
     if in_library or in_arc then writeln(usr,'Renaming not allowed.');
    end;

   overlay Procedure File_Status;
      var
      temp_file:file;
      name,workname:filename;
      i:integer;
      visible:boolean;
      this:fileptr;

    begin
    if (not in_library) and (not in_arc) and ((user_rec.access>=250)
    or (not remote_copy)) then
     begin
      writeln(usr);
      name:=correct_fn(prompt('Filename',12,'ES'));
      if (name<>'') and (name<>' ') then
        begin
          this:=dirbase; workname:='';
          while (this<>nil) and (workname<>name) do
            begin
              workname:=this^.fname; {used to compare names}
              visible:=(($80 and ord(workname[11]))=0); {true when hi bit off}
              while pos(' ',workname)>0 do
                delete(workname,pos(' ',workname),1); {remove spaces}
              for i:=1 to length(workname) do
                workname[i]:=chr($7f and ord(workname[i])); {reset high bits}
              this:=this^.next;
            end;
          if workname=name then
            begin
              Write(usr,'File ',name,' is ');
              if visible then writeln(usr,'visible.')
              else writeln(usr,'invisible.');
              if ask('Do you want to change status') then
                begin
                  setsect(setdrv,setusr);
                  assign(temp_file,name);
                  i:=pos('.',name)+2;
                  if visible then
                      name[i]:=chr($80 or ord(name[i])); {turn sys bit on}
                  {$I-} Rename(Temp_file,name); {$I+}
                  if ioresult=0 then  writeln(usr,'Status Changed.')
                  else writeln(usr,'Error - Status not changed.');
                end;
            end
          else
          Writeln(usr,name,' not found.');
        end;
      setsect(homdrv,homusr);
      ReadDir(direntries,dirspace,dirbase);
     end
     else
     if in_library or in_arc then Writeln(usr,'ARC/LBR Status change not allowed.');
    end;

overlay procedure config_sys;
  var num:integer;
      menu,ets,co,am,ll,r300,rp:char;

  procedure display_settings;
    begin
      writeln(usr);
      writeln(usr,'1...Min. disk space req. to allow uploads..........  ',maxfree_uplds);
      writeln(usr,'2...Min. disk space req. to allow new users........  ',maxfree_logs);
      writeln(usr,'3...Min. disk space req. to NOT limit msg. length..  ',maxfree_mslimit);
      writeln(usr,'4...Msg. lines allowed when limited by disk space..  ',maxfree_lines);
      writeln(usr,'5...Absolute min. disk space for any operations....  ',maxfree_abs);
        write(usr,'6...Extra time added during certain hours..........  ');
      if extra_time_sw then writeln(usr,'ON')
      else writeln(usr,'OFF');
      writeln(usr,'7...Hours extra time on system is added............  ',extra_time_start,'-',extra_time_stop);
      writeln(usr,'8...Minutes of extra time to be added..............  ',extra_time_val);
        write(usr,'9...Allow caller Chat:.............................  ');
      if chat_ok then writeln(usr,'ON')
      else Writeln(usr,'OFF');
      writeln(usr,'10..Hours Chat allowed:                              ',chatstart,'-',chatend);
      writeln(usr,'11..Seconds to wait before input timeout:            ',sleepy_time);
      writeln(usr,'12..Max. tries for names, password befor hangup:     ',max_tries);
        write(usr,'13..Automatic macro operation [requires clock]:....  ');
      if auto_macro then writeln(usr,'ON')
      else writeln(usr,'OFF');
      writeln(usr,'14..Starting hour for auto macro execution:          ',auto_macro_start);
        write(usr,'15..Limiting number of max. message lines:.........  ');
      if limit_lines then writeln(usr,'ON')
      else writeln(usr,'OFF');
      writeln(usr,'16..Maximum number of message lines allowed:         ',max_msg_lines);
        write(usr,'17..Restrict 300 baud callers from using system:...  ');
      if restrict300 then writeln(usr,'ON')
      else writeln(usr,'OFF');
      writeln(usr,'18..Hours to restrict 300 baud use:                  ',start_restrict300,'-',end_restrict300);
      writeln(usr,'19..Downloads allowed / upload [ 0 = Unrestricted]:  ',up_down_ratio);
        write(usr,'20..Restrict public messages until sysop approves:   ');
      if restrict_public then writeln(usr,'ON')
      else writeln(usr,'OFF');
      seek(logr_file,0); read(logr_file,logr_rec);
      writeln(usr,'21..Caller Number..................................  ',
        logr_rec.user);
    end;

begin  {config sys}
  repeat
    writeln(usr);
    st:=prompt('<S>ystem parameters,  <P>urge parameters,  <Q>uit',10,'ES');
    if (length(st)=1) and (st<>' ') then menu:=st[1]
    else menu:='Q';
    if (menu in ['S','P']) then
      repeat
        writeln(usr);
        if menu='S' then display_settings
        else display_purge_settings;
        writeln(usr);
        num:=strint(prompt('Number to change...<Return> to continue',2,'E'));
        if Menu='S' then change_settings(num)
        else change_purge_settings(num);
      until (num=0) or (not online);
  until (menu='Q') or (not online);
  if online then Write_Config_File;
end;

Overlay Procedure Articles;
  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;
       this:artptr;
       sect_rec:section_rec;
       num:integer;
  begin
    If ArtBase<>Nil then
      begin
        assign(sect_file,sect_name+ext);
        reset(sect_file);
        repeat
          this:=artbase;
          writeln(usr);
          writeln(usr,'ARTICLES AVAILABLE FOR VIEWING');
          writeln(usr);
          while (this<>nil) do      
            begin
              seek(sect_file,this^.artrec);
              read(sect_file,sect_rec);
              if (user_rec.access>=this^.artaccs) then
              writeln(usr,this^.artnum,'   ',sect_rec.sdesc);
              this:=this^.next;
            end;
          writeln(usr);
          num:=strint(prompt('Number of Article to read [0 to exit]',3,'E'));
          this:=artbase;
          while (this<>nil) and (this^.artnum<>num) do this:=this^.next;
          if (this^.artnum=num) and (user_rec.access>=this^.artaccs) then
            List_file(this^.artname,this^.artdrive,this^.artuser);
        until (not online) or (num=0);
        close(sect_file);
      end
    else
      begin
        writeln(usr);
        writeln(usr,' Articles are not available at this time.');
        writeln(usr);
      end;
  end;

{ end of PICS2J.inc }