home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol079 / fcbs.pli < prev    next >
Text File  |  1984-04-29  |  12KB  |  486 lines
  1.   /* * * * * * * * * * * * * * * * * * * * * * * * * * * *
  2.    *                                                     *
  3.    *                       FCBs                          *
  4.    *                                                     *
  5.    *             COUNT ACTIVE FCBS ON DRIVE              *
  6.    *                                                     *
  7.    * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  8.  
  9.         /* COPYRIGHT 1981, Digital Research */
  10.  
  11. /* fcbs - display and edit CP/M directory sectors */
  12.     fcbs: procedure options(main);
  13.     /* by Doug Huskey */
  14.     %replace
  15.        TRUE           by '1'b,
  16.        FALSE          by '0'b,
  17.        VERDATE        by '02/23/81',
  18.        CLEAR_SCRN     by '^[*^Z  ',
  19.        HELP_CMD       by 'HELP    ',
  20.        DUMP_CMD       by 'DUMP    ',
  21.        DISPLAY_CMD    by 'DISPLAY ',
  22.        VALID_DRIVES   by 'ABCDEFGHIJKLMNOP';
  23.  
  24.     %include 'diomod.dcl';
  25.     %include 'plibios.dcl';
  26.  
  27.  
  28.     declare
  29.        date       char(8) external static init(VERDATE);
  30.  
  31.     declare
  32.        1 search      based(dfcb0()),
  33.          3 drive       fixed(7),
  34.          3 name        char(8),
  35.          3 type        char(3),
  36.          3 ext         char(1);
  37.  
  38.  
  39.     declare
  40.        1 default1      based(dfcb0()),
  41.          3 space       fixed(7),
  42.          3 command     char(8);
  43.  
  44.  
  45.     declare
  46.        dirptr            pointer,
  47.        1 dir_fcb(0:19)   based(dirptr),
  48.          3 user          bit(8),
  49.          3 fname         char(8),
  50.          3 ftype         char(3),
  51.          3 fext          fixed(7),
  52.          3 fs1           bit(8),
  53.          3 fs2           bit(8),
  54.          3 frc           fixed(7),
  55.          3 falloc(16)    bit(8);
  56.  
  57.     declare
  58.        1 dirm(0:19)      based(dirptr),
  59.          3 user          fixed(7),
  60.          3 fname(8)      bit(8),
  61.          3 ftype         char(3),
  62.          3 fext          fixed(7),
  63.          3 fs1           bit(8),
  64.          3 fs2           bit(8),
  65.          3 frc           fixed(7),
  66.          3 falloc(16)    bit(8);
  67.  
  68.     declare
  69.        usrfcbs(0:16)     fixed(15) static init
  70.                          (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  71.  
  72.  
  73.     declare            /* disk parameter header mask */
  74.        dphp            ptr,
  75.        1 dph_mask   based(dphp),
  76.          2 xlt      ptr,
  77.          2 space(3) bit(16),
  78.          2 dirbuf   ptr,
  79.          2 dpbptr   ptr,
  80.          2 csvptr   ptr,
  81.          2 alvptr   ptr;
  82.  
  83.  
  84.     declare            /* disk parameter block mask */
  85.        dpbp        ptr,
  86.        1 dpb_mask  based(dpbp),
  87.          2 spt     fixed(15),
  88.          2 blkshft fixed(7),
  89.          2 blkmsk  fixed(7),
  90.          2 extmsk  fixed(7),
  91.          2 dsksiz  fixed(15),
  92.          2 dirmax  fixed(15),
  93.          2 fill    bit(16),
  94.          2 checked fixed(15),
  95.          2 offset  fixed(7);
  96.  
  97.  
  98.  
  99.   /* * * * * * * * * * * * * * * * * * * * * * * * * * * *
  100.    *                                                     *
  101.    *                    MAIN PROGRAM                     *
  102.    *                                                     *
  103.    * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  104.  
  105.  
  106.  
  107.  
  108.     declare
  109.        odump          entry(ptr,fixed),        /* hex dump */
  110.        odrv           fixed(7),            /* original drive */
  111.        drv            char(4) varying,
  112.        dcnt           fixed(15) static init(0),    /* fcb # */
  113.        dump           bit(1) static init(false),    /* hex dump */
  114.        disp           bit(1) static init(false),    /* display  */
  115.        numfcbs        fixed(15) static init(0),    /* # of fcbs */
  116.        fcbx           fixed(7),        /* fcb index in cur_sec */
  117.        i              fixed(7),
  118.        cur_sec      fixed(15);        /* current dir sector */
  119.  
  120.     on error begin;
  121.        declare
  122.           errcode;
  123.  
  124.        errcode = oncode();
  125.        if errcode < 80 then do;
  126.           put skip list('Fatal Error #:',errcode);
  127.           call reboot();
  128.           end;
  129.        go to brk;
  130.        end;
  131.  
  132.     /* INITIALIZATION */
  133.  
  134.     allocate dir_fcb set (dirptr);
  135.     if break() then
  136.         drv = rdcon();
  137.     odrv = curdsk();
  138.     call dselect(drive);
  139.     if substr(search.name,1,1) ~= ' ' then 
  140.         if command = DUMP_CMD then
  141.             dump = true;
  142.          else if command = DISPLAY_CMD then
  143.             disp = true;
  144.         else if command = HELP_CMD then do;
  145.             put skip list('FCBS - Display Number of Directory Entries');
  146.             put skip(2) list('Command line options:');
  147.             put edit('FCBS','FCBS d:','FCBS <filename>',
  148.             'FCBS HELP','FCBS DUMP','FCBS DISPLAY')
  149.                 (skip(2),a);
  150.             put skip(2);
  151.             call reboot();
  152.             end;
  153.         else  do;
  154.             call dir_search;
  155.             go to brk;
  156.             end;
  157.     call count_fcbs;
  158. brk:    
  159.     put skip(2);
  160.         do i = 0 to 15;
  161.         if usrfcbs(i) ~= 0 then
  162.             put skip list(usrfcbs(i),'FCB(s) on user',deblank(char(i,10)));
  163.         end;
  164.     if usrfcbs(16) ~= 0 then
  165.             put skip(2) list(usrfcbs(16),
  166.             'undefined (GARBAGE) FCB(s)');
  167.     drv = ascii(65+curdsk()) || ':';
  168.     put skip(2) list(numfcbs,'FCB(s) are assigned on',drv);
  169.     if substr(search.name,1,1) ~= ' ' then 
  170.         put list(search.name||'.'||search.type);
  171.     put skip;
  172.     call select(odrv);
  173.     call reboot;
  174.  
  175.   /* * * * * * * * * * * * * * * * * * * * * * * * * * * *
  176.    *                                                     *
  177.    *                    SUBROUTINES                      *
  178.    *                                                     *
  179.    * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  180.  
  181.  
  182.  
  183.  
  184. /* count_fcbs - count active fcbs on drive */
  185.     count_fcbs: procedure;
  186.     dcl 
  187.         j fixed(7);
  188.  
  189.     if disp then
  190.         call header;
  191.     numfcbs = 0;
  192.         do dcnt = 0 to dirmax by 20;
  193.         call read_dir;
  194.             do j = 0 to 19 while (cur_sec * 4 + j <= dirmax);
  195.             call count(j);
  196.             end;
  197.         end;
  198.     end count_fcbs;
  199.  
  200. /* dir_search - count matching fcb entries */
  201.     dir_search: proc;
  202.     dcl
  203.         fnd   bit(1);
  204.  
  205.     fnd = false;
  206.     numfcbs = 0;
  207.     if search_first() then
  208.         call found;
  209.  
  210.         do while(search_next());
  211.         call found;
  212.         end;
  213.  
  214.     found: proc;
  215.         if ~fnd then do;
  216.             fnd = true;
  217.             call header;
  218.             end;
  219.         call count(fcbx);
  220.         if ~disp & dirm(fcbx).user < 16 then
  221.             call line(fcbx);
  222.         end found;
  223.     end dir_search;
  224.  
  225. /* search_first - search for first match in directory
  226.          if found set dcnt and read dir */
  227.     search_first: procedure returns(bit(1));
  228.     
  229.     dcnt = 0;
  230.     call read_dir;
  231.     if sn(0) then 
  232.         return(true);
  233.     else
  234.         return(search_next());
  235.     end search_first; 
  236.  
  237. /* search_next - search for next match in directory
  238.          if found set dcnt and read dir */
  239.     search_next: procedure returns(bit(1));
  240.     dcl k fixed;
  241.  
  242.     
  243.     k = fcbx + 1;
  244.     if sn(k) then 
  245.         return(true);
  246.     else
  247.         do k = dcnt+4 to dirmax by 20;
  248.         dcnt = k;
  249.         call read_dir;
  250.         if sn(0) then
  251.             return(true);
  252.         end;
  253.     return(false);
  254.     end search_next; 
  255.  
  256. /* sn - search for match in dir_fcb(j) to dir_fcb(19)
  257.          if found set dcnt and read dir */
  258.     sn: procedure(j) returns(bit(1));
  259.     declare
  260.             file        char(11),
  261.             k           fixed(7),
  262.         (i,j)       fixed(15);
  263.     
  264.     declare
  265.             1 smsk      based(dfcb0()),
  266.               3 drv     fixed(7),
  267.               3 msk     char(11);
  268.  
  269.         do i = j to 19 while (cur_sec * 4 + i <= dirmax);
  270.         if disp then
  271.             call line(i);
  272.         file = dir_fcb(i).fname || dir_fcb(i).ftype;
  273.             do k = 1 to 11;
  274.             if substr(msk,k,1) = '?' then
  275.                 substr(file,k,1) = '?';
  276.             end;
  277.         if msk = file then do;
  278.             dcnt = dcnt + i - fcbx;
  279.             call read_dir;
  280.             return(true);
  281.             end;
  282.         end;
  283.     return(false);
  284.     end sn; 
  285.  
  286.  
  287. /* read_dir - read 5 sectors of director into dir_fcb */
  288.     read_dir: proc;
  289.     dcl
  290.        s fixed(15),
  291.        i fixed(7);
  292.  
  293.     call set_cursec;
  294.     i = 0;
  295.        do s = cur_sec to cur_sec + 4;
  296.        call read_sector(s, addr(dir_fcb(i)),dump);
  297.        i = i + 4;
  298.        end;
  299.     call break_test;
  300.     end read_dir;
  301.  
  302.  
  303. /* set_cursec - set up current directory parameters */
  304.     set_cursec: proc;
  305.  
  306.     cur_sec = divide(dcnt,4,15);
  307.     fcbx = mod(dcnt,4);
  308.     end set_cursec;
  309.  
  310. /* dselect - select disk drive */
  311.     dselect: procedure((d));
  312.     dcl d fixed(7);
  313.  
  314.     if d = 0 then
  315.         d = curdsk();
  316.     else
  317.         d = d - 1;
  318.     call select(d);
  319.     dphp = seldsk(d);
  320.     dpbp = dpbptr;
  321.     end dselect;
  322.  
  323. /* count - count fcb line j */
  324.     count: proc(j);
  325.     declare
  326.         j        fixed(7);
  327.  
  328.     if dir_fcb(j).user ~= 'E5'b4 then do;
  329.         if dirm.user(j) < 16 then
  330.             usrfcbs(dirm.user(j)) = usrfcbs(dirm.user(j)) + 1;
  331.         else
  332.             usrfcbs(16) = usrfcbs(16) + 1;
  333.         numfcbs = numfcbs + 1;
  334.         if disp | (dirm(j).user > 15) then 
  335.             call line(j);
  336.         end;
  337.     end count;
  338.  
  339.  
  340. /* header - display fcb line header */
  341.     header: proc;
  342.  
  343.     put skip(2) edit('#','user','file name','extent')
  344.                     (x(5),a(2),a(6),a(17),a);
  345.     put skip;
  346.     end header;
  347.  
  348. /* line - display fcb line i */
  349.     line: proc(j);
  350.     declare
  351.         j        fixed(7);
  352.  
  353.     put skip edit(numfcbs)(f(6));
  354.     if dir_fcb(j).user ~= '00'b4 then
  355.         put edit (dir_fcb(j).user) (x(3),b4);
  356.     else
  357.         put edit ('') (a(5));
  358.     put edit(dir_fcb(j).fname||'.'||dir_fcb(j).ftype)
  359.         (x(2),a);
  360.     if dir_fcb(j).fext ~= 0 then
  361.         put list(dir_fcb(j).fext);
  362.     if dirm(j).user > 15 then
  363.         put list('       * * * GARBAGE FCB * * *');
  364.     end line;
  365.  
  366.  
  367. /* read_sector - read logical record # to dma address
  368.      - input: 1) logical record # 
  369.                   2) dma address  */
  370.     read_sector: procedure(s,a,d);
  371.     dcl 
  372.        s   fixed(15),
  373.        a   pointer,
  374.        d   bit(1);
  375.  
  376.     call settrk( track(s) );
  377.     call setsec( sector(s) );
  378.       call setdma( a );
  379.     if d then 
  380.         call sector_heading(s);
  381.     if rdsec() ~= 0 then 
  382.         signal error(71);
  383.     if d then 
  384.         call odump (a,128);
  385.     end read_sector;
  386.  
  387.  
  388.  
  389. /* sector - convert logical record # to physical sector */
  390.     sector: procedure(i) returns(fixed);
  391.     dcl i fixed;
  392.  
  393.     return(sectrn(mod(i,spt),xlt));
  394.     end sector;
  395.  
  396.  
  397. /* track  - logical record # to physical track */
  398.     track: procedure(i) returns(fixed);
  399.     dcl i fixed;
  400.  
  401.     return(offset + divide(i,spt,15));
  402.     end track;
  403.  
  404.  
  405. /* block  - logical record # to physical block */
  406.     block: procedure(i) returns(fixed);
  407.     dcl i fixed;
  408.  
  409.     return(divide(i,(blkmsk + 1),15));
  410.     end block;
  411.  
  412. /* break_test - test for console break */
  413.     break_test: procedure;
  414.     dcl
  415.         c char(1);
  416.  
  417.        if break() then do;
  418.         c = rdcon();
  419.         if c ~= '^S' then 
  420.             signal error(80);
  421.         end;
  422.     end break_test;
  423.  
  424.  
  425.  
  426. /* sector_heading - display track, sector and block for absolute sector i */
  427.     sector_heading: proc(i);
  428.     declare
  429.         i        fixed;
  430.  
  431.     put skip(2) edit('Track:')(a);
  432.     call hex(track(i));
  433.     put edit('Sector:')(col(18),a);
  434.     call hex(sector(i));
  435.     put edit('Block:')(col(59),a);
  436.     call hex(block(i));
  437.     end sector_heading;
  438.  
  439. /* hex - display hex of binary(15) value (v) 
  440.     hex: proc(v);
  441.     declare
  442.         v        fixed,
  443.         p        ptr,
  444.         byte(2)  bit(8) based(p);
  445.  
  446.     p = addr(v);
  447.     put edit(byte(2),byte(1))(x(2),b4,b4);
  448.     end hex; */
  449.  
  450.  
  451. /* hex - display hex of binary(15) value (v) */
  452.     hex: proc(v);
  453.     declare
  454.         v        fixed,
  455.         i        fixed(7),
  456.         sig      bit(1),
  457.         p        ptr,
  458.         word     bit(16) based(p);
  459.  
  460.     sig = false;
  461.     p = addr(v);
  462.     put list(' ');
  463.         do i = 1 to 9 by 4;
  464.         if substr(word,i,4) ~= '0'b4 | sig then do;
  465.             sig = true;
  466.             put edit(substr(word,i,4))(b4);
  467.             end;
  468.         else
  469.             put list('');
  470.         end;
  471.         put edit(substr(word,13,4))(b4);
  472.  
  473.     end hex;
  474.  
  475.  
  476. /* deblank - deblank integers in char(10) form */
  477.     deblank: proc(num) returns(char(10) varying);
  478.     declare
  479.         num char(10);
  480.  
  481.     return( substr(num, verify(num,' ')));
  482.     end deblank;
  483.  
  484.     end fcbs;
  485.  
  486.