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

Text File | 1987-06-11 | 11.0 KB | 313 lines

{PICS2H1.INC  Pascal Integrated Communications System }
{ 6/11/87  vers 1.6 Copyright 1987 by Les Archambault}

overlay procedure process_macro;
  var
    done,continue: boolean;
    ed_macro: StrStd;
    ch:char;
    i:integer;
  begin
    done := FALSE;
    repeat
      writeln(USR);
      st:=prompt('Macro command <D><E><S><Q><?> ',80, 'ES?');
      if length(st)=1 then ch:=st[1]
      else ch:='?';
      case ch of
        'D': writeln(USR, macro);
        'E': begin
               continue:=true;
               Assign(macro_file,'MACRO.LST');
               {$I-} Reset(macro_file); {$I+}
               if ioresult=0 then
                 begin
                   writeln(usr);
                   write(usr,'The MACRO.LST file exists and must be edited');
                   writeln(usr,' with a text editor.');
                   continue:=ask('do you want to edit the in-memory macro');
                   close(macro_file);
                 end;
               if continue then
                 begin
                   ed_macro := macro;
                   GetStr(ed_macro, ch, 79, 'ES');
                   writeln(USR);
                   macro := ed_macro;
                   setsect(HomDrv,HomUsr);
                   Write_Config_File;
                 end;
             end;
        'S': begin
               done:=true;
               Assign(macro_file,'MACRO.LST');
               {$I-} Reset(macro_file); {$I+}
               if ioresult=0 then
                 begin
                   if ask('Do you want to execute the MACRO.LST file') then
                     begin
                       macro_file_exists:=true;
                       writeln('Starting macro execution.');
                       macro_in_progress:=true;
                     end
                   else close(macro_file);
                 end
               else close(macro_file);
               if (not macro_file_exists) and (length(macro)>0) then
                 begin
                   writeln('Starting macro execution.');
                   macro_in_progress:=true;
                   next_inpstr:=macro;
                   repeat
                     i:=pos('^M',next_inpstr);
                     if i>0 then
                       begin
                         delete(next_inpstr,i,2);
                         insert(chr(13),next_inpstr,i);
                       end;
                   until i=0;
                   cmd_queue:=next_inpstr;
                   next_inpstr:='';
                   mult_cmds:=true;
                 end;
             end;
        'Q': done := TRUE
      else writeln(USR, '<D>isplay, <E>dit, <S>tart, <Q>uit');
      end;
    until (done) or (not online);
  end;

overlay procedure sys_dir;
{ Create system directory file }
  var
    TmpDrv, TmpUsr, KepDrv, KepUsr: integer;
    this: SectPtr;
    this_lbr,this_arc: fileptr;
    t: tad_array;
    DestName:Filename;
    KepReq: Str10;
    str: StrTAD;
    dir_file: text;
    include_lbr,include_arc:boolean;

  Procedure Header;
  var
    this: SysmPtr;
    rec:integer;
  begin
    this := SysmBase;
    while (this <> nil) and (this^.key <> 'G') do
      this := this^.next;
    if this^.key = 'G'
      then
        begin
          setsect(HomDrv,HomUsr);
          rec:=succ(this^.loc);
          repeat
              setsect(HomDrv,HomUsr);
              seek(sysm_file,rec);
              read(sysm_file,sysm_rec);
              rec:=succ(rec);
              setsect(TmpDrv,TmpUsr);
              if sysm_rec[1]<>':' then writeln(Dir_file, sysm_rec);
          until EOF(sysm_file) or (sysm_rec[1]=':');
          setsect(TmpDrv,TmpUsr);
          writeln(dir_file);
        end;
  end;

  procedure center(str: StrStd);
  { Center string on print line }
    begin
      writeln(dir_file, ' ':((user_rec.columns - length(str)) div 2), str);
      writeln(dir_file)
    end;

  procedure write_dir;
  { Write directory to file }
    const
      col_width = 19;
    var
      i, j, k, entries, rows, size, col_limit: integer;
      this: FilePtr;
      nodes: array[1..4] of FilePtr;
      str: Str10;
    begin
      col_limit := max(1, user_rec.columns div col_width);
      writeln(dir_file);
      if in_library then entries:=libentries
      else
      if in_arc then entries:=arcentries
      else
      entries:=direntries;
      if entries <> 0
        then
          begin
            if in_library then this:=libbase
            else
            if in_arc then this:=arcbase
            else
            this:=dirbase;
            if in_library then
            writeln(dir_file,' ** Library: ',libreq,' Files: ',entries,
            '  Space Used  ',libspace,'K')
            else
            if in_arc then
            writeln(dir_file,' * Arc File: ',arcreq,' Files: ',entries,
            '  Space Used  ',arcspace,'K')
            else
            writeln(dir_file, '   File area: ', SectReq, '   Files: ', entries,
              '   Space used: ', DirSpace, 'k');
            rows := entries div col_limit;
            if 0 <> entries mod col_limit
              then rows := succ(rows);
            nodes[1] := this;
            for i := 2 to col_limit do
              begin
                for j := 1 to rows do
                  this := this^.next;
                nodes[i] := this
              end;
            i := 1;
            while not (brk or (i > rows)) do
              begin
                for j := 1 to col_limit do
                  begin
                    this := nodes[j];
                    if (i + rows * pred(j)) <= entries
                      then
                        begin
                          size := this^.fsize shr 3;
                          if (this^.fsize mod 8) <> 0
                            then size := succ(size);
                          str := intstr(size, 4) + 'k ';
                          if size>0 then
                          write(dir_file, this^.fname, str)
                          else write(dir_file,'                 ');
                          if j < col_limit
                            then write(dir_file, fence, ' ')
                            else writeln(dir_file)
                        end
                      else writeln(dir_file);
                    nodes[j] := nodes[j]^.next   { Go to next on list }
                  end;
                i := succ(i)
              end
          end;
      if j <> col_limit
        then writeln(dir_file)
    end;

  begin { sys_dir }
    writeln(usr);
    write(usr,'Select File Section where SYSTEM.DIR will be written:');
    DestName:=Get_Section_name(' ');
    writeln(usr);
    include_lbr:= ask('Include Library breakdown');
    include_arc:= ask('Include Arc breakdown');
    if ch<>ETX then
      begin
        writeln(usr);
        write(USR, 'Building system directory...Please wait...');
        KepDrv := SetDrv;
        KepUsr := SetUsr;
        KepReq := SectReq;
        FindSect(DestName, TmpDrv, TmpUsr, OK);
        if not OK then
          begin
            TmpDrv := HomDrv;
            TmpUsr := HomUsr
          end;
        SetSect(TmpDrv, TmpUsr);
        Assign(dir_file, 'SYSTEM.DIR');
        {$I-} Rewrite(dir_file) {$I+};
        OK := (IOresult = 0);
        if OK then
          begin
            header;
            center('Complete System Directory Listing');
            center('as of');
            GetTAD(t);
            setsect(homdrv,homusr);
            str := FormTAD(t);
            setsect(tmpdrv,tmpusr);
            center(str);
            this := SectBase;
            while (this <> nil) and (not brk) and (online) do
              begin
                if this^.SectAccs <= val_acc then
                  begin
                    SectReq := this^.SectName;
                    SetDrv  := this^.SectDrive;
                    SetUsr  := this^.SectUser;
                    SetSect(HomDrv, HomUsr);
                    ReadDir(DirEntries, DirSpace, DirBase);
                    SetSect(TmpDrv, TmpUsr);
                    write_dir;
                    if include_lbr then
                      begin
                        this_lbr:=dirbase;
                        while this_lbr<>Nil do
                          begin
                            if copy(this_lbr^.fname,10,3)='LBR' then
                              begin
                                libreq:=this_lbr^.fname;
                                while pos(' ',libreq)>0 do
                                 delete(libreq,pos(' ',libreq),1);
                                setsect(homdrv,homusr);
                                LibReadDir(libentries,libspace,libbase);
                                setsect(tmpdrv,tmpusr);
                                write_dir;
                                if in_library then
                                  begin
                                     in_library:=false;
                                     setsect(setdrv,setusr);
                                     close(libr_file);
                                     setsect(tmpdrv,tmpusr);
                                   end;
                              end;
                            this_lbr:=this_lbr^.next;
                          end;
                      end; {include lbr}

                    if include_arc then
                      begin
                        this_arc:=dirbase;
                        while this_arc<>Nil do
                          begin
                            if copy(this_arc^.fname,10,3)='ARC' then
                              begin
                                arcreq:=this_arc^.fname;
                                while pos(' ',arcreq)>0 do
                                 delete(arcreq,pos(' ',arcreq),1);
                                setsect(homdrv,homusr);
                                ArcReadDir(Arcentries,Arcspace,Arcbase);
                                setsect(tmpdrv,tmpusr);
                                write_dir;
                                if in_arc then
                                  begin
                                     in_arc:=false;
                                     setsect(setdrv,setusr);
                                     close(arc_file);
                                     setsect(tmpdrv,tmpusr);
                                   end;
                              end;
                            this_arc:=this_arc^.next;
                          end;
                      end; {include arc}
                  end;     {section<access}
                  this := this^.next
              end; {this<>nil}
            Close(dir_file);
            SetSect(Homdrv, HomUsr);
            SectReq := KepReq;
            SetDrv := KepDrv;
            SetUsr := KepUsr;
            ReadDir(DirEntries, DirSpace, DirBase)
          end;   {file opened ok}
        writeln(USR);
      end;
  end;

{end of PICS2H1.INC }