[inherit ('sys$library:starlet')] program view_system (input,output);

type
	buffer_type	= packed array [1..255] of char;
	$quad		= [quad,unsafe] record
				u0	: unsigned;
				l1	: integer;
			  end;
	$ubyte		= [byte] 0..255;
	$uquad		= [quad,unsafe] record
				u0	: unsigned;
				u1	: unsigned;
			  end;
	$uword		= [word] 0..65535;

	dummy_rec	= record
			  end;

	integeritem	= packed record
				length	: $uword;
				code	: $uword;
				address : [unsafe] ^[unsafe] dummy_rec;
				retlen	: ^integer;
			  end;

	stringitem	= packed record
				length	: $uword;
				code	: $uword;
				address : [unsafe] ^ [unsafe] buffer_type;
				retlen	: ^integer;
			  end;


const
	space		= ' ';


var
	account		: [volatile] packed array [1..10] of char;
	account_len	: [volatile] integer;
	dummy		: integer;
	input_line	: varying [63] of char;
	input_line_len	: $uword;
	imagnam		: [volatile] packed array [1..63] of char;
	imagnam_len	: [volatile] integer;
	logintime	: packed array [1..23] of char;
	logintm		: [volatile] $uquad;
	logintm_len	: [volatile] integer;
	offset		: integer;
	pid_no		: [volatile] unsigned;
	pid_len		: [volatile] integer;
	pidroot		: [volatile] unsigned;
	prcnam		: [volatile] packed array [1..12] of char;
	prcnam_len	: [volatile] integer;
	pstate		: packed array [1..5] of char;
	status		: [volatile] $uquad;
	state		: [volatile] integer;
	state_len	: [volatile] integer;
	nosys		: boolean;
	uic_no		: [volatile] unsigned;
	uic_len		: [volatile] integer;
	usernam		: [volatile] packed array [1..10] of char;
	usernam_len	: [volatile] integer;

	jpilist		: packed record
				accnt	     	: stringitem;
				pid	     	: integeritem;	
				procname     	: stringitem;
				username     	: stringitem;
				logintim     	: integeritem;
				prcstate	: integeritem;
				imagname	: stringitem;
				uic		: integeritem;
				listend		: integer;
			  end;

[external, asynchronous] function lib$get_foreign
	(var getstr	: varying [$get1] of char;
	     prompt	: varying [$get2] of char := %immed 0;
	 var outlen	: $uword) : integer; external;

[external, asynchronous] function str$find_first_substring
	(    str1	: varying [$fnd1] of char;
	 var index	: integer;
	 var subindex	: integer;
	     str2	: [class_s] packed array [$fnd2..$fnd3:integer]
				of char) : boolean; external;


begin		{ Main Procedure }

with jpilist do
begin
	accnt.length	:= 10;
	accnt.code	:= jpi$_account;
	accnt.address	:= address (account);
	accnt.retlen	:= address (account_len);
	pid.length	:= 04;
	pid.code	:= jpi$_pid;
	pid.address	:= address (pid_no);
	pid.retlen	:= address (pid_len);
	procname.length := 12;
	procname.code	:= jpi$_prcnam;
	procname.address:= address (prcnam);
	procname.retlen	:= address (prcnam_len);
	username.length	:= 10;
	username.code	:= jpi$_username;
	username.address:= address (usernam);
	username.retlen	:= address (usernam_len);
	logintim.length	:= 08;
	logintim.code	:= jpi$_logintim;
	logintim.address:= address (logintm);
	logintim.retlen	:= address (logintm_len);
	prcstate.length := 08;
	prcstate.code	:= jpi$_state;
	prcstate.address:= address (state);
	prcstate.retlen	:= address (state_len);
	imagname.length	:= 63;
	imagname.code	:= jpi$_imagname;
	imagname.address:= address (imagnam);
	imagname.retlen	:= address (imagnam_len);
	uic.length	:= 04;
	uic.code	:= jpi$_uic;
	uic.address	:= address (uic_no);
	uic.retlen	:= address (uic_len);
	listend  := 0;
end;

status := lib$get_foreign (getstr := input_line, outlen := input_line_len);
if str$find_first_substring (input_line, dummy, dummy , '/NOSYS')
	then nosys := true
	else nosys := false;

pidroot := -1;
status := 0;

writeln ('  PID    Process name   Owner        Login time    State   Image');

while status.u0 <> ss$_nomoreproc do
begin
	$getjpiw (pidadr := pidroot, itmlst := jpilist, iosb := status);

	{ The following fixes a $GETJPI problem with string padding }

	if index (account, chr(0)) <> 0 then
		account_len := index (account, chr(0)) - 1;
	if index (prcnam, chr(0)) <> 0 then
		prcnam_len := index (prcnam, chr(0)) - 1;
	if index (usernam, chr(0)) <> 0 then
		usernam_len := index (usernam, chr(0)) - 1;

	account := pad (substr (account, 1, account_len), ' ', 8);
	$asctim (timbuf := logintime, timadr := logintm);
	offset := index (imagnam,'.]') + 2;
	if offset = 2 then offset := index (imagnam,':') + 1;
	if offset > 0 then
		imagnam := substr (imagnam, offset, length(imagnam) - offset);
	offset := index (imagnam,']') + 1;
	imagnam := substr (imagnam, offset, length(imagnam) - offset);
	case state of
		01 : pstate := 'COLPG';
		02 : pstate := 'MWAIT';
		03 : pstate := 'CEF  ';
		04 : pstate := 'PFW  ';
		05 : pstate := 'LEF  ';
		06 : pstate := 'LEFO ';
		07 : pstate := 'HIB  ';
		08 : pstate := 'HIBO ';
		09 : pstate := 'SUSP ';
		10 : pstate := 'SUSPO';
		11 : pstate := 'FPGW ';
		12 : pstate := 'COM  ';
		13 : pstate := 'COMO ';
		14 : pstate := 'CUR  ';
	otherwise pstate := '???  ';
	end;

	uic_no := uic_no div 65356;
	if (status.u0 <> ss$_nomoreproc) and not (nosys and (uic_no <= 4)) then
     	begin
	     	if (state in [02,06,08,10,13]) or (status.u0 = ss$_suspended) then
	     	begin
			logintime := '--Not available--';
			imagnam := '--Not available--';
		end;
	     	if (logintm.u0 = 0) and (logintm.u1 = 0)
	     	then writeln (hex(pid_no,8,8), space,
	     		pad (substr (prcnam, 1, prcnam_len), space, 12))
	     	else writeln (hex(pid_no,8,8), space,
	     		pad (substr (prcnam, 1, prcnam_len), space, 12),
	     		space,
	     		pad (substr (usernam, 1, usernam_len), space, 10),
	     		space,
	     		logintime:17,
	     		space,
			space,
	     		pstate:5,
			space,
			pad(substr(imagnam,1,min(21,imagnam_len)),space,21));
	end;
end;
end.
