{WHAT--The command to show process information

  John Fritz 
  MCV Academic Computing
  Medical College of Virignia
  Box 16, MCV Station
  Richmond, VA   23298
  (804) 786-9843
  }

[inherit('sys$library:starlet',
         'mcv:rtl',
         'mcv:mcvlib',
         'whatStuff')]program what;

[asynchronous,unbound] procedure setTrue(var b: boolean);
begin b := true; $wake end;

procedure chec(i: integer);
begin
   if not odd(i) then lib$signal(i);
   end;

const
   maxNodes = 16;
var
   proc: array[1..maxNodes*maxproc] of info;
   numProc: integer;

procedure sort;
type
   sortProc = record
      proc: array[1..maxNodes*maxproc] of sortInfo;
      end;
const
   stackSize = 31;
   maxPartition = 6;
var
   s: 0..stackSize;
   stack: array [0..stackSize-1] of record l,r: integer end;
   split: keyType;
   i,j,l,r: integer;
   temp: sortInfo;
begin with proc::sortProc do begin
   {Quicksort proc}
      s := 1; stack[0].l := 1; stack[0].r := numProc;
      repeat
         {pop the stack}
            s := s-1; l := stack[s].l; r := stack[s].r;
         while r-l >= maxPartition do begin {split proc}
            i := l; j := r; split := proc[(l+r) div 2].key;
            repeat
               while proc[i].key < split do i := i+1;
               while proc[j].key > split do j := j-1;
               if i <= j then begin
                  temp := proc[i]; proc[i] := proc[j]; proc[j] := temp;
                  i := i+1; j := j-1;
                  end
               until i > j;
            if j-l < r-i then begin 
               if r-i >= maxPartition then begin {push right partition}
                  stack[s].l := i; stack[s].r := r; s := s+1 end;
               r := j; {continue sorting left partition}
               end
            else begin
               if j-l >= maxPartition then begin {push left partition}
                  stack[s].l := l; stack[s].r := j; s := s+1 end;
               l := i; {continue sorting right partition}
               end;
            end;
         until s = 0;
      {end of Quicksort}
   {Now bubblesort for maxPartition-1 passes to handle the partitions
    that Quicksort left unsorted}
      for i := 1 to maxPartition-1 do begin
         for j := numProc-1 downto 1 do begin
            if proc[j].key > proc[j+1].key then begin
               temp := proc[j+1]; proc[j+1] := proc[j]; proc[j] := temp; end;
            end;
         end;
       {end of bubblesort}
   end end; {sort}

type
   str = varying[max(size(proc[1].userName),
                     size(proc[1].prcnam),
                     size(proc[1].image)+1)] of char;
var
   checkList: array[1..512] of str;

type
   checkRange = record lo,hi: integer end;

function found(
       subject: str;
       pat: checkRange): boolean;
var
   sub: str;
   lim,i: integer;
begin
   lim := pat.hi+1; i := pat.lo;
   while i <> lim do begin
      if checkList[i].length > subject.length then i := i+1
      else begin
         str$upcase(%descr sub,substr(subject,1,checkList[i].length));
         if sub = checkList[i] then lim := i else i := i+1;
         end;
      end;
   found := lim <= pat.hi;
   end;
   
type
   pidRec = record lo,hi: $uword end;
var
   nodeInfo: [volatile] array[1..maxNodes+1] of [volatile] record
      nodeName: [volatile] nodeType;
      okToRead: [volatile] boolean;
      lockBlock: [volatile] record
         stat: [volatile] $uword;
         reserved: [volatile] $uword;
         lockId: [volatile] unsigned;
         end;
      allProc,interProc,batchProc,networkProc: integer;
      end := zero;
   nodeWanted: array[1..maxNodes+1] of nodeType;
   numWanted: integer;
   clusterStat: integer;
   lockName: varying[nodeLen+length(mcvWhat)] of char;
   id: record
      val,attr: unsigned
      end;
   itemList: record
      bufLen,item: $uword;
      bufAddr,retLen,sentinel: integer
      end := (nodeLen,syi$_nodeName,0,0,0);
   message: file of jpiString;
   nodes: integer;
   syiStat: integer;
   wildcard: integer := -1;
   nodesRead: integer;
   n,p,w: integer;
   include: boolean;
   oldMaster: integer;
   whatTable: [external] cli_tableType;
   userWanted,prcWanted,imageWanted: checkRange;
   allUser, allPrc, allImage, everyImage: boolean;
   shoDetached, shoInter, shoBatch, shoNetwork, shoSub: boolean;
   out: text;
   outName: varying[255] of char;
begin
   cli_parse_foreign(whatTable,'what');
   cli$get_value('output', %descr outName);
   if outName.length = 0 then outName := 'SYS$OUTPUT';
   open(out,outName,default:='WHAT.LIS',history:=new); rewrite(out);
   if not odd(cli$present('mode')) then begin
      {show everything but detached}
      shoInter := true; shoBatch := true; 
      shoNetwork :=true; shoSub := true;
      shoDetached := false;
      end
   else begin
      if odd(cli$present('mode.all')) then begin
         shoDetached := true; shoInter := true; shoBatch := true; 
         shoNetwork :=true; shoSub := true;
         end
      else begin
         shoDetached := odd(cli$present('mode.detached'));
         shoInter := odd(cli$present('mode.interactive'));
         shoBatch := odd(cli$present('mode.batch'));
         shoNetwork := odd(cli$present('mode.network'));
         shoSub := odd(cli$present('mode.subprocess'));
         end;
      end;
   with userWanted do begin
      lo := 1; hi := 0;
      while odd(cli$get_value('user', %descr checkList[hi+1])) do hi := hi+1;
      allUser := hi < lo;
      end;
   with prcWanted do begin
      lo := userWanted.hi+1; hi := lo-1;
      while odd(cli$get_value('process', %descr checkList[hi+1])) do
         hi := hi+1;
      allPrc := hi < lo;
      end;
   with imageWanted do begin
      allImage := not odd(cli$present('image'));
      lo := prcWanted.hi+1; hi := lo-1;
      while odd(cli$get_value('image', %descr checkList[hi+1])) do 
         hi := hi+1;
      everyImage := hi < lo;
      end;
   clusterStat := cli$present('cluster');
   if clusterStat = cli$_negated then begin
      nodes := 1;
      with nodeInfo[1]do begin
         nodeName := myNode;
         chec($enq(,LCK$K_PRMODE,lockBlock,LCK$M_SYSTEM,
            mcvWhat+nodeName,astAdr:=%immed setTrue,
            astPrm:=iaddress(okToRead)));
         end;
      end
   else begin
      numWanted := 0;
      clusterStat := cli$get_value('cluster', %descr nodeWanted[numWanted+1]);
      while odd(clusterStat) do begin
         if numWanted <> maxNodes then numWanted := numWanted + 1;
         clusterStat := cli$get_value('cluster', 
                                       %descr nodeWanted[numWanted+1]);
         end;
      nodes := 0;
      with nodeInfo[1] do begin
         itemList.bufAddr := iaddress(nodeName.body);
         itemList.retLen := iaddress(nodeName.length);
         end;
      syiStat := $getsyiw(csidadr:=%ref wildCard,itmLst:=itemList);
      w := 0;
      while syiStat = ss$_normal do begin
         if numWanted > 0 then begin
            nodeWanted[numWanted+1] := nodeInfo[nodes+1].nodeName;
            w := 1;
            while index(nodeInfo[nodes+1].nodename,nodeWanted[w]) <> 1 do 
               w := w+1;
            end;
         if w <= numWanted then begin
            nodes := nodes+1;
            with nodeInfo[nodes] do 
               chec($enq(,LCK$K_PRMODE,lockBlock,LCK$M_SYSTEM,
                  mcvWhat+nodeName,astAdr:=%immed setTrue,
                  astPrm:=iaddress(okToRead)));
            with nodeInfo[nodes+1] do begin
               itemList.bufAddr := iaddress(nodeName.body);
               itemList.retLen := iaddress(nodeName.length);
               end;
            end;
         syiStat := $getsyiw(csidadr:=%ref wildCard,itmLst:=itemList);
         end;
      if syiStat <> ss$_noMoreNode then chec(syiStat);
      end;
   nodesRead := 0; numProc := 0;
   repeat
      for n := 1 to nodes do with nodeInfo[n] do if okToRead then begin
         chec(lockBlock.stat);
         open(message,nodeName+'.lis;',default:=myName,
            history:=readonly,sharing:=readonly); reset(message);
         while not eof(message) do begin
            with message^::jpiRecType do begin
               allProc := jpiLen div next(info);
               for p := 1 to allProc do with jpi[p] do begin
                  case mode of
                     jpi$K_network: begin
                        networkProc := networkProc+1;
                        include := shoNetwork;
                        end;
                     jpi$K_batch: begin
                        batchProc := batchProc+1;
                        include := shoBatch;
                        end;
                     jpi$K_interactive: begin
                        interProc := interProc+1;
                        include := shoInter;
                        end;
                     otherwise begin
                        if pid = master_pid then include := shoDetached
                        else include := shoSub;
                        end;
                     end;
                  if include and 
                     (allUser or found(userName,userWanted)) and
                     (allPrc or found(prcNam,prcWanted)) and
                     (allImage or 
                        (everyImage and 
                           (substr(image,1,5) <> '(dcl)') and
                           (image[1] <> ' ')) or
                        found(image,imageWanted)) then begin
                     numProc := numProc+1;
                     proc[numProc] := jpi[p];
                     end;
                  end;
               end;
            get(message);
            end;
         close(message);
         $deq(lockBlock.lockId);
         okToRead := false;
         nodesRead := nodesRead+1;
         end;
      if nodesRead <> nodes then $hiber;
      until nodesRead = nodes;
   sort;
   for n := 1 to nodes do with nodeInfo[n] do writeln(out,
      nodeName:6,' has ',
         interProc:1,   ' interactive, ',
         batchProc:1,   ' batch, ',
         networkProc:1, ' network, ',
         allProc:1,     ' total processes');
   writeln(out);
   writeln(out,' Node   Term    User Name    Process Name   PID  CPU Time   Connect    Image');
   writeln(out,'====== ======= ============ =============== ==== ========= ========== =========');
   oldMaster := -1;
   for p := 1 to numProc do with proc[p] do begin
      if master_pid = oldMaster then write(out,'       ')
      else begin
         oldMaster := master_pid;
         write(out,node+' ');
         end;
      writeln(out,terminal+' '+userName+' '+ prcNam+' '+hex(pid::pidRec.lo,4,4)+
              ' '+cpu+' '+connect+' '+image);
      end;
   end.
