{ Whatserver--waits for WHAT to trigger it; then stores process information
  in a file

  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',
         'whatStuff')]program whatserver(output);

{Whatserver executes the following infinite loop:                              }
{                                                                              }
{    establish an exclusive lock on lock_N                                     }
{    hibernate until receipt of a blocking AST on lock_N                       }
{    get JPI information on every process on node_N                            }
{    write this information to file_N                                          }
{    convert the exclusive lock to a null lock (allowing others to read file_N)}

[asynchronous,unbound] procedure wakeup; begin $wake end;

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

type
   jpiIndex = (jMasterPid,jMode,jUser,jPrcNam,  {items to be returned from     }
               jPid,jTerm,jCpu,jLogin,jImage,   {$getjpi                       }
               jSentinel);                      {end of list flag              }
   jpiListType = array[jpiIndex] of record;
      bufLen,item: $uword;
      bufAddr,retLen: unsigned;
      end;
   quadStr = packed array[1..size($quad)] of char;
   char256 = packed array[1..256] of char;
const
   firstDirect = jMasterPid;	{We tell $getjpi to put direct items           }
   lastDirect = jPid;           {in jpiRec; other items go first to temporary  }
                                {buffers and a massaged value is put in jpiRec }
   nullQuad = quadStr(repeat chr(0));
   phyDevLen = 64;
var
   nodeName: shortNodeType;	{Name of the cluster node we are running on    }
   lockBlock: record
      stat: $uword;
      reserved: $uword;
      lockId: unsigned;
      end;
   message: file of jpiString;
   jpiRec: [volatile] jpiRecType;

   {Whatserver uses a double buffering arrangement so that as it is formatting }
   {the information returned by one call of in one buffer, it calls $getjpi    }
   {asynchronously to fill the other buffer.                                   }

   request: array[boolean] of record	{Double buffer for $getjpi requests    }
      efn: integer;                     {Event flag                            }
      reqStat: integer;                 {Status returned by $getjpi            }
      iosb: [volatile] record           {I/O status block                      }
         stat,reserved: integer;                    
         end;
      jpiList:  [volatile] jpiListType; {Item list for $getjpi.                }
                                        {Will point partly to items in jpiRec  }
                                        {and partly to items in this buffer    }
      cputim:   [volatile] unsigned;    {CPU time                              }
      logintim: [volatile] $quad;       {Login time                            }
      imagName: [volatile] fileSpec;    {Name of image the process is running  }
      term:	[volatile] varying[8] of char;	{Terminal name                 }
      phydev:   [volatile] varying[phyDevLen] of char;	{Physical terminal     }
      userLen:  [volatile] $uword;	{Returned length of username           }
      prcLen:   [volatile] $uword;      {Returned length of process name       }
      dviList: oneItem;                 {Itemlist for $getdvi                  }
      end;

   {firstJpi[b] is used to initialize request[b].jpiList at the beginning of   }
   {each cycle of $getpji requests.			                       }

   _j: info;		  {used only for size information in firstJpiList below}

   firstJpi: array[boolean] of jpiListType := (repeat(
      (size(_j.master_pid),		jpi$_master_pid,            {jMasterPid}
       byte_offset(info,master_pid),	0),
      (size(_j.mode),			jpi$_mode,                  {jMode}
       byte_offset(info,mode),		0),
      (size(_j.userName),		jpi$_userName,              {jUser}
       byte_offset(info,userName),	0),
      (size(_j.prcnam),			jpi$_prcnam,                {jPrcNam}
       byte_offset(info,prcnam),	0),
      (size(_j.pid),			jpi$_pid,                   {jPid}
       byte_offset(info,pid),		0),
      (size(request[false].term)-2,	jpi$_terminal,              {jTerm}
       0,				0),
      (size(unsigned),			jpi$_cputim,                {jCpu}
       0,				0),
      (size($quad),			jpi$_logintim,              {jLogin}
       0,				0),
      (imageLen,			jpi$_imagname,              {jImage}
       0,				0),
      (0,0,0,0)));                                                  {jSentinel}

   jpiBase: unsigned;		{pointer to the first element in jpiRec.jpi    }
   jpiLimit: unsigned;          {pointer to the last element in jpiRec.jpi     }
   procs: integer;		{number of processes found		       }
   wildcard: unsigned;          {wildcard context for $getjpi                  }
   now: $quad;			{The current time (approximately)              }
   clean: array[char] of char;  {Translation table to eliminate unprintables   }
                                {and translate to lower case                   }
   b: boolean;       
   j: jpiIndex;
   i: integer;
   period: integer;
   seconds,minutes,hours,days: unsigned;
   dayString: varying[3] of char;
   diff: $quad;
   fileName: varying[nodeLen+4] of char;
   r: boolean;
const                                      
   jpiStride = next(info);
label
   forever;

begin with jpiRec do begin

   clean::char256 :=
      '                                 !"#$%&''()*+,-./0123456789:;<=>?@'+
      'abcdefghijklmnopqrstuvwxyz[\]^ `abcdefghijklmnopqrstuvwxyz{|}~'+
      '                                  !cl y sx@x<    x+23 xp. 1o>42 ?'+
      'aaaaaaaceeeeiiii nooooooouuuuy baaaaaaaceeeeiiii nooooooouuuuy  ';

   jpiBase := (address(jpi))::unsigned;

   for b := false to true do begin

      {Set direct items to point to items in jpi[1] for b = true and           }
      {jpi[0] for b = false (jpi[0] doesn't exist, but the pointers            }
      {will be updated to point to jpi[2] before being used)                   }

         for j := firstDirect to lastDirect do with firstJpi[b,j] do 
            bufAddr := bufAddr + jpiBase - ord(not b)*jpiStride;

      with request[b] do begin

         {Set other items to point to correct place in buffer}
            firstJpi[b,jTerm].bufAddr  := (address(term.body))::unsigned;
            firstJpi[b,jTerm].retlen   := (address(term.length))::unsigned;
            firstJpi[b,jUser].retlen   := (address(userLen))::unsigned;
            firstJpi[b,jPrcNam].retlen := (address(prcLen))::unsigned;
            firstJpi[b,jCpu].bufAddr   := (address(cputim))::unsigned;
            firstJpi[b,jLogin].bufAddr := (address(logintim))::unsigned;
            firstJpi[b,jImage].bufAddr := (address(imagname.body))::unsigned;
            firstJpi[b,jImage].retLen  := (address(imagname.length))::unsigned;

         {Set up the $getdvi request list} 
            dviList := oneItem(phyDevLen,dvi$_TT_phydevnam,0,0,0);
            dviList.bufAddr            := (address(phydev.body))::unsigned;
            dviList.retlen             := (address(phydev.length))::unsigned;

         chec(lib$get_ef(efn));

         end;

      end;                 

   jpiLimit := firstJpi[true,firstDirect].bufAddr+jpiBase+maxProc*jpiStride;

   {Set nodeName to name of the cluster node we are running on}
      if myNode.length <= shortNodeLen then 
         nodeName := pad(myNode,' ',shortNodeLen)
      else nodeName := 
         substr(myNode,myNode.length-shortNodeLen+1,shortNodeLen);
      for i := 2 to length(nodeName) do nodeName[i] := clean[nodeName[i]];

   fileName := myNode+'.lis;';

   {Initialize the lock to null}
      chec($enqw(,LCK$K_NLMODE,lockBlock,LCK$M_SYSTEM,mcvWhat+myNode));
      chec(lockBlock.stat);

   forever:

      {Change the lock to exclusive mode}
         chec($enqw(,LCK$K_EXMODE,lockBlock,LCK$M_SYSTEM+LCK$M_CONVERT,
              blkAst := wakeUp));
         chec(lockBlock.stat);

      {Empty the message file}
         open(message,fileName,default:=myName,history:=unknown,sharing:=none);
         rewrite(message);

      {Initialize the $getjpi buffers}
         request[false].jpiList := firstJpi[false]; 
         request[true].jpiList := firstJpi[true]; 

      wildCard::integer := -1;
      procs := 0; 
      r := true;

      $hiber;		{Until we are blocking someone's lock}

      {Make the first $getpji request}
         with request[true] do begin
            reqStat := $getjpi(efn,wildcard,,jpiList,iosb);
            if (reqStat <> ss$_noMoreProc) and (reqStat <> ss$_suspended) then 
                chec(reqStat);
            end;

      chec($gettim(now));

      while request[r].reqStat <> ss$_noMoreProc do begin

         {Wait for $getjpi to get back}
            with request[r] do begin
               $synch(efn,iosb);
               reqStat := iosb.stat;
               end;

         if request[r].reqStat <> ss$_noMoreProc then begin

            procs := procs+1;

            {Submit the next request}
               with request[not r] do begin
                  {The pointers now point into jpi[procs]-1; make them}
                  {point into jpi[proc+1]                             }
                     for j := firstDirect to lastDirect do with jpiList[j] do 
                        bufAddr := bufAddr + 2*jpiStride;
                  {If we've run out of room, pretend we've run out of processes}
                     if jpiList[firstDirect].bufAddr = jpiLimit then 
                        reqStat := ss$_noMoreProc
                     else reqStat := $getjpi(efn,wildcard,,jpiList,iosb);
                  if (reqStat <> ss$_noMoreProc) and (reqStat <> ss$_suspended)
                     then chec(reqStat);
                  end;

            with request[r], jpi[procs] do begin

               if reqStat = ss$_suspended then imagName := '***susp***'
               else chec(reqStat);

               node := nodeName;

               if master_pid = 0 then begin
                  master_pid := pid;
                  lib$trim_filespec(imagName,image);
                  end
               else if imagName.length = 0 then image := '(DCL)    '
               else lib$trim_filespec(imagName,image);

               {Clean up image name}
                  period := index(image,'.');
                  if period = 0 then period := length(image)+1;
                  for i := 1 to period-1 do image[i] := clean[image[i]];
                  for i := period to length(image) do image[i] := ' ';

               {Set  subprocess flag}
                  if pid = master_pid then sub := 'N' 
                  else begin sub := 'Y'; mode := jpi$K_other end;

               {Set terminal name}
                  if term.length = 0 then {Use process type} case mode of
                     jpi$K_network:     terminal := 'Network';
                     jpi$K_batch:       terminal := 'Batch  ';
                     jpi$K_interactive: terminal := 'Session';
                     otherwise          terminal := '       ';
                     end
                  else if term.length = 1 then terminal := term+'    '
                  else begin
                     if substr(term,1,2) = 'VT' then begin
                        {Use physical terminal name, if possible}
                           reqStat := $getdviw(efn,,'_'+term,dviList,iosb);
                           if (reqStat <> ss$_noSuchDev) and 
                              (iosb.stat <> ss$_noSuchDev) then begin
                              chec(reqStat); chec(iosb.stat);
                              if phydev.length > 8 then phydev.length := 8;
                              if phydev.length > 1 then begin
                                 if phydev[1] = '_' then 
                                    term := substr(phydev,2,phydev.length-1)
                                 else term := phydev;
                                 end;
                              end;
                           end;
                     if term.length > 6 then terminal := substr(term,1,7)
                     else terminal := pad(term,' ',7);
                     for i := 1 to length(terminal) do if terminal[i] < ' ' then
                        terminal[i] := ' ';
                     end;

               for i := 1 to length(userName) do 
                  userName[i] := clean[userName[i]];

               for i := 1 to length(prcnam) do if prcnam[i] < ' ' then
                  prcnam[i] := ' ';

               {Get CPU time}
                  seconds := (cputim+50) div 100;
                  minutes := seconds div 60; seconds := seconds mod 60;
                  hours := minutes div 60; minutes := minutes mod 60;
                  days := hours div 24; hours := hours mod 24;
                  if days = 0 then cpu := 
                     ' '+dec(hours,2,2)+':'+dec(minutes,2,2)+':'+
                         dec(seconds,2,2)
                  else begin
                     if seconds >= 30 then begin
                        minutes := minutes+1;
                        if minutes > 60 then begin
                           minutes := 0; hours := hours +1;
                           if hours > 24 then begin
                              hours := 0; days := days+1;
                              end;
                           end;
                        end;
                     writev(dayString,days:3);
                     cpu := dayString+' '+dec(hours,2,2)+':'+dec(minutes,2,2); 
                     end;

               {Get connect time}
                  if logintim::quadStr = nullQuad then
                     connect := pad(' ',' ',size(connect))
                  else begin
                     chec(lib$subx(logintim,now,diff));
                     chec($asctim(,connect,diff));
                     end;

               end;

            r := not r;

            end;
         end;

      jpiLen := procs*next(info);
 
      write(message,substr(jpiRec::jpiString,1,jpiLen));
      close(message);

      chec($enqw(,LCK$K_NLMODE,lockBlock,LCK$M_SYSTEM+LCK$M_CONVERT));

      goto forever;

   end end.
