;WHERE.MAR displays information about processes and devices
.TITLE WHERE
.IDENT 'V04-007'
;
;*******************************************************************************
;* *
;* THIS SOFTWARE IS MAINTAINED AT THE CALIFORNIA INSTITUTE OF TECHNOLOGY *
;* ASTRONOMY DATA PROCESSING FACILITY. IT MAY BE COPIED AND DISTRIBUTED *
;* WITHOUT RESTRICTION. *
;* *
;* CALTECH ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF THIS *
;* SOFTWARE. *
;* *
;*******************************************************************************
;
;
; DESCRIPTION:
;
; WHERE displays information about processes and devices.
;
; WHERE searches the I/O data base for all terminals that are in use,
; and displays selected information about the owners' processes, along
; with terminal locations retrieved from file WHERE_PORTS.
; Options include listing subprocesses and batch jobs, sorting output
; by username, selecting or discarding output by search string, and
; listing users of allocated devices (other than terminals).
;
;
; General qualifiers:
;
; /INTERACTIVE - Include interactive users
; /SORT - Sort by username
; /BATCH - Include batch jobs
; /SUBPROCESSES - Include sub-processes
; /FULL - Same as /INTER/SORT/BATCH/SUBPROC
; /ALL_PROCESSES - Include all processes on system
; /ALLOCATED_DEVICES - Include list of allocated devices
; /DCL - Exclude processes not at DCL level
; /LONG - Use long output formats
;
; Qualifiers which select the information to be listed about each process:
;
; /PID - PID
; /USERNAME - username
; /PROCESS_NAME - process name (if different from
; username and terminal ID)
; /UIC - UIC (octal format)
; /TERMINAL - terminal ID
; /TYPE - terminal type
; /IMAGE - name of currently executing image
; /STATE - process state
; /PRIORITY - current and base priorities
; /DIRECT_IO - direct I/O count
; /BUFFERED_IO - buffered I/O count
; /PAGE_FAULTS - number of page faults
; /WORKING_SET - working set size
; /PHYSICAL_MEMORY - number of pages the process has
; in physical memory.
; /CPU_TIME - CPU time
; /ELAPSED_TIME - elapsed time
; /LOCATION - location
;
;
; SITE SPECIFIC MODIFICATIONS:
;
; The BADDEV list contains device types that should be ignored.
; The BADUSRNAM and BADPRCNAM lists contain usernames and process names
; which should be ignored unless the /ALL_PROCESSES qualifier is
; specified.
;
;
; BUILDING:
;
; Assemble with SYS$LIBRARY:LIB/LIB
; Link with SYS$SYSTEM:SYS.STB/SEL (/NOTRACE)
; Install with privileges: CMKRNL - to get device info
; WORLD - to get process info
; OPER - to get queue info
;
;
; AUTHORS:
;
; Kimo B. Yap
; Jon L. Vavrus
;
;
; MODIFICATIONS:
;
; V04-007 17-OCT-1985 PCP
; VMS V4.2. Add QUI$_SEARCH_FLAGS.
;
; V04-006 24-SEP-1985 PCP
; Fix bad R6 reference in QUI_HANDLER.
;
; V04-005 25-JUL-1985 PCP
; Remove duplicate /FULL from command definition. Increase
; maximum device count from 128 to 256.
;
; V04-004 7-MAY-1985 PCP
; Interface with command definition utility.
; Enhance search string capability to immitate DCL SEARCH command
; (multiple strings; /EXACT; /MATCH=)
; Corrections for virtual terminal names with more than 3 digits.
;
; V04-003 6-APR-1985 PCP
; Batch processing restored. The code can be greatly simplified
; if the new (yet undocumented) system service $GETQUI eventually
; acquires an argument or item code for PID.
;
; V04-002 28-FEB-1985 PCP
; TTYTYP macro modified to reference TT$_ symbols ($TTDEF)
; rather than DT$_ ($DCDEF). Additional entries made in TRMTAB
; for new terminal types. Code added to output routine
; for terminal type to prevent out-of-bounds references in TRMTAB.
;
; V04-001 19-FEB-1985 PCP
; Batch processing has been eliminated, since it was dependent
; on the format of the queue data base under previous versions
; of VMS.
;
; Internal format PIDs taken from the I/O data base are
; converted to extended format for use with $GETJPI.
;
; Virtual terminal names are converted to physical device
; names for the ports file search.
;
; The executive mode routine to search the I/O data base
; has been replaced by a user mode routine having the same call
; interface. The first time the new routine is entered, it calls a
; kernel mode routine that locks the data base and runs through the
; device list, copying the desired data to a buffer allocated from
; process virtual memory. VMS system routines are used as much as
; possible. Information on these routines was obtained from the VMS
; source code for the SHOW DEV command and associated routines from
; module IOSUBNPAG of facility SYS.
;
;
.PAGE
.SBTTL COMMAND DEFINITION
;
; DEFINE VERB WHERE
; IMAGE sys:[sysprog]where
; PARAMETER P1, LABEL=SEARCH_STRING, VALUE (LIST)
; QUALIFIER INTERACTIVE, DEFAULT
; QUALIFIER SORT
; QUALIFIER BATCH
; QUALIFIER SUBPROCESSES
; QUALIFIER FULL
; QUALIFIER ALL_PROCESSES
; QUALIFIER ALLOCATED_DEVICES, DEFAULT
; QUALIFIER DCL, DEFAULT
; QUALIFIER LONG
; QUALIFIER PID
; QUALIFIER USERNAME, DEFAULT
; QUALIFIER PROCESS_NAME, DEFAULT
; QUALIFIER UIC
; QUALIFIER TERMINAL, DEFAULT
; QUALIFIER TYPE, DEFAULT
; QUALIFIER IMAGE, DEFAULT
; QUALIFIER STATE
; QUALIFIER PRIORITY
; QUALIFIER DIRECT_IO
; QUALIFIER BUFFERED_IO
; QUALIFIER PAGE_FAULTS
; QUALIFIER WORKING_SET
; QUALIFIER PHYSICAL_MEMORY
; QUALIFIER CPU_TIME, DEFAULT
; QUALIFIER ELAPSED_TIME
; QUALIFIER LOCATION, DEFAULT
;
; QUALIFIER EVERY_FIELD
;
; QUALIFIER EXACT
; QUALIFIER MATCH, NONNEGATABLE, DEFAULT, VALUE (TYPE=MATCH)
;
; DEFINE TYPE MATCH
; KEYWORD OR, DEFAULT
; KEYWORD AND
; KEYWORD NOR
; KEYWORD NAND
;
.PAGE
.SBTTL DECLARATIONS
$TPADEF
$JPIDEF
$UCBDEF
$DCDEF
DC$_UNKNOWN= 0 ; Add this one for AP
$TTDEF
$DDBDEF
$DEVDEF
$STATEDEF
$SECDEF
$UCBDEF
$CHFDEF
$SSDEF
BLANK= ^A\ \ ; ASCII blank
TAB= 9 ; ASCII tab
V_LINE= ^A\|\ ; ASCII |
D_QUOTE= ^A\"\ ; ASCII "
TILDA= ^A\~\ ; ASCII ~
SLASH= ^A\/\ ; ASCII /
PORT_COMMENT= ^A\!\ ; Comment delimiter in port file
IMAG_BUF_LEN= 64 ; Length of image name buffer
PRC_BUF_LEN= 15 ; Length of process name buffer
TERM_BUF_LEN= 16 ; Length of terminal buffer
USR_BUF_LEN= 12 ; Length of username buffer
KEY_LEN= USR_BUF_LEN+PRC_BUF_LEN+TERM_BUF_LEN+4
.PAGE
.SBTTL PSECT DEFINITIONS
.PSECT CODE,BYTE,NOWRT,EXE,SHR,GBL,RD
.PSECT STRINGS,BYTE,RD,NOWRT,NOEXE,SHR,GBL
.PSECT DATA_WRT,LONG,NOEXE,RD,WRT,NOSHR,GBL
.PSECT DATA_RD,BYTE,RD,NOWRT,NOEXE,SHR,GBL
.PAGE
.SBTTL MACROS
;
; .ADDR
;
.MACRO .ADDR ADDRESS
.ADDRESS 'ADDRESS'
.ENDM .ADDR
;
; ASCII_TAB
;
; This macro constructs a table of equivalent characters for the ASCII
; character set (256 bytes). OLD is the string of ASCII values to be
; substituted for ( specifies a range). It should be seperated by
; commas and enclosed in angle brackets (<>). FILL is a string of
; characters to be used as replacements.
;
.MACRO ASCII_TAB CHRVAL,FILLCHR=<.>,?L1
A_TAB.= 0
L1: .REPEAT 256 ; Create table
.BYTE A_TAB.
A_TAB.= A_TAB.+1
.ENDR
.FILLCHR= 0
..FILLCHR= %LENGTH(FILLCHR) - 1
.IRP A_TAB.,<'CHRVAL'>
.A_TAB= %LOCATE(<->,A_TAB.)
..A_TAB= %LENGTH(A_TAB.) - .A_TAB - 1
.IF EQUAL ..A_TAB+1
.= L1+'A_TAB.'
.ASCII \%EXTRACT(.FILLCHR,1,<'FILLCHR'>)\
.IF_FALSE
...A_TAB= .A_TAB+1
.A_TAB= %EXTRACT(0,.A_TAB,A_TAB.)
.= L1+.A_TAB
....A_TAB= %EXTRACT(...A_TAB,..A_TAB,A_TAB.)
.A_TAB = ....A_TAB-.A_TAB
.REPEAT .A_TAB
.ASCII \%EXTRACT(.FILLCHR,1,<'FILLCHR'>)\
.ENDR
.ENDC
.IIF NOT_EQUAL ..FILLCHR-.FILLCHR,.FILLCHR=.FILLCHR+1
.ENDR
.= L1+256
.ENDM
;
; FLAGDEF
;
; Creates a symbol ITM_V_name and ITM_M_name for a unique
; bit position in FLAGS2. ITM_V_name is the bit number and ITM_M_name
; is the mask.
;
.MACRO FLAGDEF NAME
.IF NOT_DEFINED NEXT_2_BIT
NEXT_2_BIT=0
.ENDC
ITM_V_'NAME'=NEXT_2_BIT
ITM_M_'NAME'=1@NEXT_2_BIT
NEXT_2_BIT=NEXT_2_BIT+1
.ENDM FLAGDEF
;
; $GETJPI
;
; This macro calls SYS$GETJPI in the proper way, including the wait for
; the event flag and seting and clearing a timer request so that there
; is no "infinite" wait.
;
.MACRO $GET_JPI PIDADR=0,PRCNAM=0,ITMLST,IOSB=0,ASTADR=0,-
ASTPRM=#0,GEF=0,WEF=31,WAITIM,ERR,?LAB1
.GLOBL SYS$GETJPI
$QIOPUSH ASTPRM,ASTADR
$PUSHADR IOSB,CONTEXT=Q
$PUSHADR ITMLST,CONTEXT=L
$PUSHADR PRCNAM,CONTEXT=Q
$PUSHADR PIDADR,CONTEXT=L
PUSHL #GEF
CALLS #7,G^SYS$GETJPI
.IF BLANK ERR
BLBC R0,LAB1
.IF_FALSE
BLBC R0,ERR
.ENDC
.IF BLANK WAITIM
.IF NOT_DEFINED $$GJP$TEMP
.SAVE_PSECT
.PSECT DATA_RD,BYTE,RD,NOWRT,NOEXE,SHR,GBL
$$GJP$TEMP: .LONG -20000000,-1
.RESTORE_PSECT
.ENDC
$SETIMR_S EFN=#WEF,DAYTIM=$$GJP$TEMP
.IF_FALSE
$SETIMR_S EFN=#WEF,DAYTIM=WAITIM
.ENDC
$WFLOR_S EFN=#GEF,MASK=#^B1@GEF+<1@WEF>
.IF NOT_DEFINED $$GJP$TEMP2
.SAVE_PSECT
.PSECT DATA_WRT,LONG,RD,WRT,NOEXE,NOSHR,GBL
$$GJP$TEMP2: .LONG
.RESTORE_PSECT
.ENDC
$READEF_S EFN=#GEF,STATE=$$GJP$TEMP2
CMPL #SS$_WASSET,R0
BNEQ LAB1
$CANTIM_S
MOVL #SS$_WASSET,R0
LAB1:
.ENDM
;
; OUTTAB
;
; Output field definitions.
;
.MACRO OUTTAB TYPE,JPI= ,JPISIZ=4,JPIBUF,JPILEN=0,HEAD= ,-
HEAD_LONG= ,JPI2= ,JPISIZ2=4,JPIBUF2,JPILEN2=0,-
SWITCH= ,?L1,?L2,?L3
.SAVE_PSECT LOCAL_BLOCK
.PSECT DATA_WRT,LONG,NOEXE,RD,WRT,NOSHR,GBL
.IIF NOT_DEFINED OUTTAB_V,OUTTAB_V=0
.IF NOT_DEFINED RTN_TAB
RTN_TAB: .BLKL 32 ; Define routine address table
.ENDC
.IIF NOT_DEFINED OUTTAB_ENT_LEN,OUTTAB_ENT_LEN=12
.IF NOT_DEFINED OUT_TAB
OUT_TAB: .BLKB OUTTAB_ENT_LEN*32 ; Define header/getjpi table
.ENDC
ITM_V_'TYPE'=OUTTAB_V ; Define symbols
ITM_M_'TYPE'=1@OUTTAB_V
.IF BLANK <'HEAD'>
; Check for end of outputs
.IIF DEFINED FIRST_OUT_V,LAST_OUT_V=OUTTAB_V-1
.IF_FALSE
; Check for start of outputs
.IF NOT_DEFINED FIRST_OUT_V
FIRST_OUT_V=OUTTAB_V
ALL_OUT_FIELDS=1@OUTTAB_V
.IF_FALSE
ALL_OUT_FIELDS=ALL_OUT_FIELDS!<1@OUTTAB_V>
.ENDC
.SAVE_PSECT ; Define GETJPI stuff
.PSECT STRINGS,BYTE,RD,NOWRT,NOEXE,SHR,GBL
.IF NOT_BLANK <'JPI'>
L1: .WORD JPISIZ,JPI$_'JPI'
.ADDR JPIBUF
.ADDR JPILEN
.IF NOT_BLANK <'JPI2'>
.WORD JPISIZ2,JPI$_'JPI2'
.ADDR JPIBUF2
.ADDR JPILEN2
.ENDC
.LONG 0
.ENDC
L2: .ASCIC \'HEAD'\
.IF BLANK <'HEAD_LONG'> ; No "long" format
L3: .ASCIC \'HEAD'\
.IF_FALSE ; "Long" formats
L3: .ASCIC \'HEAD_LONG'\
.ENDC
.RESTORE_PSECT
.TEMP=.
.=OUT_TAB+
.IF BLANK ; Store addresses in table
.LONG 0
.IF_FALSE
.ADDR L1
.ENDC
.ADDR L2
.ADDR L3
.=.TEMP
.ENDC
OUTTAB_V=OUTTAB_V+1
.IIF GE, OUTTAB_V-32, .ERROR ; OUTTAB overflow
.IF NOT_BLANK <'SWITCH'>
MULTI_SWITCH SWITCH,ITM_M_'TYPE'
.ENDC
.RESTORE_PSECT
.ENDM OUTTAB
;
; MULTI_SWITCH
;
.MACRO MULTI_SWITCH SWITCH,FLAGS,?L1
.SAVE_PSECT LOCAL_BLOCK
.PSECT DATA_WRT
.IF NOT_DEFINED SWITCH_TAB
SWITCH_TAB_MAX = 48
SWITCH_TAB_COUNT = 0
SWITCH_TAB:
.BLKL 2*SWITCH_TAB_MAX +1 ; +1 for end-of-list (zero longword)
.ENDC
.SAVE_PSECT
.PSECT STRINGS
L1: .ASCIC \'SWITCH'\
.RESTORE_PSECT
.=SWITCH_TAB +
.ADDR L1 ; address of switch name counted string
.LONG FLAGS ; flag mask
.LONG 0 ; assume end-of-list
SWITCH_TAB_COUNT = SWITCH_TAB_COUNT + 1
.IIF GE, SWITCH_TAB_COUNT-SWITCH_TAB_MAX, .ERROR ; SWITCH_TAB overflow
.RESTORE_PSECT
.ENDM MULTI_SWITCH
;
; OUTRTN
;
.MACRO OUTRTN TYPE ; This macro defines an output formatting routine
.SAVE_PSECT LOCAL_BLOCK
.PSECT CODE,BYTE,RD,NOWRT,EXE,SHR,GBL
'TYPE'_ROUTINE:
.ENDM
.MACRO ENDRTN TYPE ; This macro ends an output formatting routine
RSB
.PSECT DATA_WRT,LONG,NOEXE,RD,WRT,NOSHR,GBL
..=.
.=RTN_TAB+<4*ITM_V_'TYPE'>
.ADDR 'TYPE'_ROUTINE
.=..
.RESTORE_PSECT
.ENDM
;
; INSERT_BLANK
;
.MACRO INSERT_BLANK ?L1 ; Inserts a leading blank in output field if
; not the first one.
BBS #ITM_V_FIRST,FLAGS2,L1
MOVB #BLANK,(AP)+
L1:
.ENDM
;
; ALLOCATED
;
.MACRO ALLOCATED LABEL,NOT= ,?L1 ; This macro branches to LABEL if the
; terminal is not marked as allocated
; OR there is no login terminal. If
; NOT is given then the opposite
; occurs
.IF BLANK <'NOT'>
BBC #ITM_V_ALLOTRM,FLAGS2,'LABEL'
TSTW LGNTRML
BEQL 'LABEL'
.IF_FALSE
BBC #ITM_V_ALLOTRM,FLAGS2,L1
TSTW LGNTRML
BNEQ 'LABEL'
L1:
.ENDC
.ENDM
;
; RMS_FNM
;
; This macro defines the filenames FNM and DNM for the given FAB.
;
.MACRO RMS_FNM FAB,FNM= ,DNM= ,?L1,?L2
.SAVE_PSECT
.PSECT STRINGS,BYTE,RD,NOWRT,NOEXE,SHR,GBL
.IF NOT_BLANK <'FNM'> ; If there is a filename
L1: .ASCII /'FNM'/ ; Define string
.RESTORE_PSECT
.RMS_TMP=.
.='FAB'+FAB$B_FNS ; Insert length
.BYTE %LENGTH(FNM)
.='FAB'+FAB$L_FNA
.ADDR L1 ; Insert address
.=.RMS_TMP
.SAVE_PSECT
.PSECT STRINGS,BYTE,RD,NOWRT,NOEXE,SHR,GBL
.ENDC
.IF NOT_BLANK <'DNM'> ; If there is a default name
L2: .ASCII \'DNM'\ ; Define string
.RESTORE_PSECT
.RMS_TMP=.
.='FAB'+FAB$B_DNS ; Insert length
.BYTE %LENGTH(DNM)
.='FAB'+FAB$L_DNA ; Insert address
.ADDR L2
.=.RMS_TMP
.IF_FALSE
.RESTORE_PSECT
.ENDC
.ENDM RMS_FNM
;
; STATETYP
;
; This macro defines all the different types of states.
;
.MACRO STATETYP TYPE= ,NAME= ,?L1
.IIF NOT_DEFINED .STATETYP,.STATETYP=0
.IF BLANK <'TYPE'>
.=STATE_TAB ; This is unknown state
.SAVE_PSECT
.PSECT STRINGS,BYTE,RD,NOWRT,NOEXE,SHR,GBL
L1: .ASCIC \'NAME'\
.IF_FALSE
.=STATE_TAB+<4*SCH$C_'TYPE'> ; Go to right place
.SAVE_PSECT ; Define string
.PSECT STRINGS,BYTE,RD,NOWRT,NOEXE,SHR,GBL
L1: .IF BLANK <'NAME'>
.ASCIC /'TYPE'/
.IF_FALSE
.ASCIC /'NAME'/
.ENDC
.ENDC
.RESTORE_PSECT
.ADDR L1 ; Load address
.IIF GREATER <.-.STATETYP>,.STATETYP=. ; Set at end
.=.STATETYP
.ENDM
;
; TTYTYP
;
; This macro is used to define the various ASCII terminal type strings.
;
.MACRO TTYTYP TYPE,NAME,?L1
.IIF NOT_DEFINED .TTYTYP,.TTYTYP=0
.IF BLANK <'TYPE'>
.=TRMTAB
.SAVE_PSECT ; Define string
.PSECT STRINGS,BYTE,RD,NOWRT,NOEXE,SHR,GBL
L1: .ASCIC \'NAME'\
.IF_FALSE
.=TRMTAB+<4*TT$_'TYPE'> ; Go to right place
.SAVE_PSECT ; Define string
.PSECT STRINGS,BYTE,RD,NOWRT,NOEXE,SHR,GBL
L1: .IF BLANK <'NAME'>
.ASCIC /'TYPE'/
.IF_FALSE
.ASCIC /'NAME'/
.ENDC
.ENDC
.RESTORE_PSECT
.ADDR L1 ; Load address
.IIF GREATER <.-.TTYTYP>,.TTYTYP=. ; Set at end
.=.TTYTYP
.ENDM
.PAGE
.SBTTL MAIN PROGRAM
.PSECT CODE
.ENTRY WHERE,^M
$CREATE FAB=SYSOUT ; Open listing file (SYS$OUTPUT)
$CONNECT RAB=OUTRAB
MOVAB SWITCH_TAB,R11 ; get addr of table of qual names/flags
CLRL FLAGS ; assume no qualifiers
5$: MOVL (R11)+,R1 ; get addr of next qual name counted str
BEQL 15$ ; branch if none
MOVZBL (R1)+,R0 ; peel off byte count to make desc
MOVQ R0,-(SP) ; put desc on stack for pass by ref
PUSHL SP ; pass addr of desc
CALLS #1,G^CLI$PRESENT ; qualifier present on command line?
MOVL (R11)+,R1 ; get the flag mask
BLBC R0,5$ ; loop if qual not present
BISL R1,FLAGS ; present, set flags according to mask
BRB 5$ ; loop for another qual
15$: CALLS #0,GET_SEARCH_LIST
BLBS R0,20$
CMPL R0,#CLI$_ABSENT
BEQL 20$
PUSHL R0
CALLS #1,G^LIB$STOP
20$:
;
40$: BICL3 #^C,FLAGS,R11 ; R11 = output flags
MOVAL GETJPI_END,R8 ; R10 = GETJPI list position
MOVAB HDRBUF,R7 ; R7 = title string position
BISL2 #ITM_M_FIRST,FLAGS2 ; Loop to get all outputs
50$: FFS #0,#32,R11,R0
BNEQ 55$
BRW 100$
55$: ASHL R0,#1,R1
BICL2 R1,R11
MULL3 #OUTTAB_ENT_LEN,R0,R6 ; Get table location
ADDL2 #OUT_TAB,R6
MOVL (R6)+,R1 ; Get GETJPI stuff
BEQL 60$
MOVQ (R1)+,(R8)+
MOVL (R1)+,(R8)+
TSTL (R1)
BEQL 60$
MOVQ (R1)+,(R8)+
MOVL (R1)+,(R8)+
60$: BBC #ITM_V_LONG,FLAGS,70$ ; Correct for /LONG
ADDL2 #4,R6
70$: MOVL (R6),R6
MOVZBL (R6)+,R0
CMPB #BLANK_FILL,(R6) ; Remove any leading blank if
BNEQ 90$ ; this is first field
BBS #ITM_V_FIRST,FLAGS2,80$
MOVB #BLANK,(R7)+
80$: DECL R0
INCL R6
90$: BICL2 #ITM_M_FIRST,FLAGS2
MOVC3 R0,(R6),(R7) ; Move header
MOVL R3,R7
BRW 50$
100$: SUBL2 #HDRBUF,R7
MOVW R7,
BBC #ITM_V_LONG,FLAGS,110$ ; Long output?
MOVL #11,TIMEDSC ; Yes, fix time descriptors
MOVL #11,CPUDSC
110$: MOVC3 #VALUE_BUF_LEN,VALUE_BUF,MASTER_BUF
$OPEN FAB=PORTFAB ; Open port file
$CONNECT RAB=PORTRAB
$PUT RAB=OUTRAB ; Output header
MOVAB RECBUF,OUTRAB+RAB$L_RBF ; Set RAB pointer to right
; buffer
BBC #ITM_V_SORT,FLAGS,LOOP
BSBW INIT_SORT ; Set up sort
.ENABLE LOCAL_BLOCK
LOOP: BICL2 #ITM_M_SUB1!ITM_M_HASTTY!ITM_M_ALLOTRM,FLAGS2
PUSHR #^M
MOVC5 #0,TRMBUF,#BLANK,#TERM_BUF_LEN,TRMBUF
POPR #^M
BBS #ITM_V_SUB2,FLAGS2,GETSB
BBS #ITM_V_BAT1,FLAGS2,GETBAT
BBS #ITM_V_ALL1,FLAGS2,GETALL
BRW GETTRM
GETALL: BSBW GET_REST ; Get any non-terminal
BLBS R0,15$ ; proc's
BISL2 #ITM_M_SUB2,FLAGS2 ; No more, revert to sub's
BICL2 #ITM_M_ALL1,FLAGS2
GETSB: REMQUE @PIDQUE,R0 ; Get next sub-process PID
BVC 10$
5$: BRW DONE
10$: MOVL 8(R0),PID
CLRL 8(R0)
PUSHR #^M
MATCHC #4,PID,#DONEPIDS_LEN,DONEPIDS
POPR #^M
BNEQ 15$
BRW LOOP
15$: BRW GETINF
GETBAT: BSBW GET_BATCH ; Get a batch job
BLBS R0,15$
BICL2 #ITM_M_BAT1,FLAGS2
20$: BBS #ITM_V_ALL,FLAGS,30$ ; No more, see about ALL/SUB
BBC #ITM_V_SUB,FLAGS,5$
BISL2 #ITM_M_SUB2,FLAGS2
BRB GETSB
30$: BISL2 #ITM_M_ALL1,FLAGS2
BRW GETALL
; If not doing a sub-process or batch job, get a terminal owner
GETTRM:
CALLG GETDEVARG,GETDEV
BISL2 #ITM_M_HASTTY,FLAGS2
BLBS R0,GETINF
BICL2 #ITM_M_HASTTY,FLAGS2
CMPL #SS$_NOSUCHDEV,R0
BNEQ 70$
BBC #ITM_V_BAT,FLAGS,20$ ; No more, see about BAT/SUB
BBC #ITM_V_ALL,FLAGS,40$
BISL2 #ITM_M_ALL1,FLAGS2
BRW GETALL
40$: BRW GETBAT
70$: $EXIT_S CODE=R0 ; Exit if strange error
; Get information on obtained PID
GETINF: MOVL PID,@LSTPID ; Mark PID as "processed"
ADDL2 #4,LSTPID
; Clear fields
MOVC3 #VALUE_BUF_LEN,MASTER_BUF,VALUE_BUF
BICL2 #ITM_M_ALLOTRM,FLAGS2
; Get info.
$GET_JPI PIDADR=PID,ITMLST=JPILST,ERR=90$
CMPL #SS$_WASSET,R0 ; All OK?
BNEQ 90$
BBS #ITM_V_SUB,FLAGS,80$
BBC #ITM_V_ALL,FLAGS,90$
80$: BSBW GET_SUB_PIDS ; Get PIDs of sub proc's
; See if we don't want this process listed.
; /Unlisted process names begin at BADPRCNAM (as counted strings)\
; \Unlisted usernames begin at BADUSRNAM (as counted strings) /
; Checks for interactiveness and DCL-ness are included here.
90$: BBC #ITM_V_HASTTY,FLAGS2,95$ ; Interactiveness
BBS #ITM_V_INT,FLAGS,95$
BRW 130$
95$: BBS #ITM_V_DCL,FLAGS,97$ ; DCL-ness
TSTW IMGLEN
BEQL 130$
CMPC5 IMGLEN,IMGNAM,#BLANK,#0,(AP)
BEQL 130$
97$: BBS #ITM_V_ALL,FLAGS,PORTS
TSTW PRCLEN
BEQL 110$
MOVAB BADPRCNAM,R0 ; Process names
100$: MOVZBL (R0),R1 ; Check for end
BEQL 110$
INCL R0
CMPC5 R1,(R0),#BLANK,PRCLEN,PRCNAM
BEQL 130$ ; If match then
; end itteration
ADDL2 R1,R0 ; Move to next name
BRB 100$
110$: TSTW USRLEN
BEQL PORTS
MOVAB BADUSRNAM,R0 ; Usernames
120$: MOVZBL (R0),R1 ; Check for end
BEQL PORTS ; If so, all OK
INCL R0
CMPC5 R1,(R0),#BLANK,USRLEN,USRNAM
BEQL 130$ ; If match then
; end itteration
ADDL2 R1,R0 ; Move to next name
BRB 120$
130$: BRW LOOP ; Not wanted, loop again
.DISABLE LOCAL_BLOCK
PORTS:
TSTW LGNTRML
BNEQ 5$
CMPL #^A\ \,TRMBUF
BEQL 10$
BRB 7$
5$:
CMPC5 TRMLEN,TRMBUF,#^A/:/,LGNTRML,LGNTRM
BEQL 10$ ; Login terminal?
7$: BISL2 #ITM_M_ALLOTRM,FLAGS2 ; No, assume allocated
10$: TSTL OWNER_PID
BEQL 12$
BISL2 #ITM_M_SUB1,FLAGS2
12$: BICL3 #^C,FLAGS,R11
BISL2 #ITM_M_FIRST,FLAGS2
PUSHL AP
MOVAB RECBUF,AP
20$: FFS #0,#32,R11,R0 ; Find an output type
BEQL 40$
ASHL R0,#1,R1
BICL2 R1,R11
MULL2 #4,R0
ADDL2 #RTN_TAB,R0
PUSHL R11 ; Save registers
JSB @0(R0) ; Execute routine
POPL R11 ; Recover registers
BICL2 #ITM_M_FIRST,FLAGS2
BRB 20$
; Check for search string match
40$: SUBL3 #RECBUF,AP,RECLEN ; Get final length
POPL AP ;
PUSHAQ RECLEN ; pass addr of desc
CALLS #1,SEARCH ; search
BLBS R0,50$ ; system err? no, branch
PUSHL R0 ; yes, signal it
CALLS #1,G^LIB$STOP ;
50$: TSTL R0 ; match?
BLSS NOUSR1 ; no, branch
70$: INCL FNDNUM ; Otherwise inc. "found" count
80$: CALLG TRIM_LIST_2,G^STR$TRIM ; Trim string
; Convert non-printing char.s
MOVTC RECLEN,RECBUF,#FILL_CHAR,MOVTC_TAB,RECLEN,RECBUF
BBC #ITM_V_SORT,FLAGS,90$
BSBW RELEASE_REC ; Output to sort or....
BRW LOOP ; Start new itteration
; Output to SYS$OUTPUT
90$: MOVW RECLEN,
$PUT RAB=OUTRAB
NOUSR1: BRW LOOP ; Start new itteration
; DONE code (done with looping)
DONE: BBC #ITM_V_SORT,FLAGS,30$
BSBW SORT_MERGE ; Sort and output if necessary
30$: CLRL R6 ; assume SYS$NODE not defined
50$: $TRNLOG_S LOGNAM=SYSNODE,RSLBUF=NODE,RSLLEN=NODE
CMPW #SS$_NORMAL,R0
BNEQ 100$
60$: CMPB @,#^A\_\ ; Clear leading underscores
BNEQ 70$
INCL
DECW NODE
BRB 60$
70$: MOVZWL NODE,R0 ; Clear trailing colons
ADDL2 ,R0
DECL R0
80$: CMPB (R0),#^A\:\
BNEQ 90$
DECL R0
DECW NODE
BRB 80$
90$: MOVL #1,R6 ; remember that NODE is valid
100$: TSTL SEARCH_LIST ; search parameter specified
BNEQ 105$ ; yes, branch
MOVAQ SUMCTR,R0 ; assume NODE invalid
BLBC R6,107$ ; NODE valid? no, branch
MOVAQ SUMCTR_NODE,R0 ;
BRB 107$ ;
105$: MOVAQ SUMCTR_MATCH,R0 ;
BLBC R6,107$ ;
MOVAQ SUMCTR_MATCH_NODE,R0 ;
107$: $FAO_S CTRSTR=(R0),- ; Format summary line
OUTLEN=OUTRAB+RAB$W_RSZ,-
OUTBUF=RECDSC,-
P1=FNDNUM,-
P2=TRMNOU,-
P3=TRMNO,-
P4=#NODE,-
P5=#0
$PUT RAB=OUTRAB ; Output summary line
CLRW OUTRAB+RAB$W_RSZ ; Output a blank line
$PUT RAB=OUTRAB
; Look for allocated devices
BBC #ITM_V_ALLO,FLAGS,110$
MOVL #DC$_TAPE,CLASS_ARG ; Tapes
BSBW GET_DEVICES
MOVL #DC$_SCOM,CLASS_ARG ; SCOM
BSBW GET_DEVICES
MOVL #DC$_REALTIME,CLASS_ARG ; Real time
BSBW GET_DEVICES
MOVL #DC$_DISK,CLASS_ARG ; Disks (floppies)
BSBW GET_DEVICES
MOVL #DC$_UNKNOWN,CLASS_ARG ; Unknown (AP)
BSBW GET_DEVICES
110$: $EXIT_S
.PAGE
.SBTTL SEARCH
.PSECT DATA_WRT
DYNSTR:
.WORD 0
.BYTE DSC$K_DTYPE_T
.BYTE DSC$K_CLASS_D
.LONG 0
SEARCH_LIST:
.BLKL 1
SEARCH_LIST_UPCASE:
.BLKL 1
SEARCH_LIST_PARAM:
.ASCID /SEARCH_STRING/
.PSECT CODE
;
; SEARCH
;
.ENTRY SEARCH,^M
MOVL 4(AP),R6 ; get addr of src string desc
MOVL SEARCH_LIST,R1 ; get addr of search list
BNEQ 5$ ; if not empty, branch to continue
BRW 95$ ; empty search list, return MATCH
5$: BBS #ITM_V_EXACT,FLAGS,10$ ; exact compare? yes, brnch, skip upcase
PUSHL R6 ; pass addr of src string desc
MOVAQ DYNSTR,R6 ; get addr of dyn str desc for return
PUSHL R6 ; pass desc addr
CALLS #2,G^STR$UPCASE ; convert to upper case
MOVL SEARCH_LIST_UPCASE,R1 ; use already upcased search list
BLBS R0,10$ ; upcase successful? yes, branch
RET ; no, return the err code
10$: MOVQ (R6),R6 ; get desc
MOVL FLAGS,R9 ; keep flags handy
MOVZBL (R1)+,R0 ; get byte count of first item in list
BGTRU 60$ ; list empty? no, branch
BITL #ITM_M_MATCH.AND!- ; AND or OR? (null string matches always
ITM_M_MATCH.OR,R9 ; if AND or OR, never if NAND or NOR)
BEQL 90$ ; no, branch, return NOMATCH
BRB 95$ ; yes, return MATCH
; Compare loop
60$: MATCHC R0,(R1),R6,(R7) ; match?
BEQL 80$ ; yes, branch
; No match
70$: BITL #ITM_M_MATCH.OR!- ; OR or NAND?
ITM_M_MATCH.NAND,R9 ;
BEQL 75$ ; no, branch
MOVAB (R1)[R0],R1 ; point to next string
MOVZBL (R1)+,R0 ; get byte count
BGTRU 60$ ; end-of-list? no, branch, compare next
BBS #ITM_V_MATCH.OR,- ; if OR then return NOMATCH
R9,90$
BRB 95$ ; else return MATCH
75$: BBS #ITM_V_MATCH.AND- ; if AND then return NOMATCH
,R9,90$ ;
BRB 95$ ; else return MATCH
; Match
80$: BITL #ITM_M_MATCH.AND!- ; AND or NOR?
ITM_M_MATCH.NOR,R9 ;
BEQL 85$ ; no, branch
MOVZBL (R1)+,R0 ; get byte count of next string
BGTRU 60$ ; end-of-list? no, branch, compare next
BBS #ITM_V_MATCH.AND,- ; if AND then return MATCH
R9,95$
BRB 90$ ; else return NOMATCH
85$: BBS #ITM_V_MATCH.OR,R9,95$ ; if OR then return MATCH
; Return values
90$: MNEGL #1,R0 ; return NOMATCH
RET
95$: MOVL #1,R0 ; return MATCH
RET
;
; GET_SEARCH_LIST
;
.ENTRY GET_SEARCH_LIST,^M
CLRL SEARCH_LIST ; assume no list present on command
CLRL SEARCH_LIST_UPCASE ; assume no list
; Read the command parameter (which may be a list). CLI$GET_VALUE success code
; is CLI$_CONCAT or CLI$_COMMA if returned item is not last in a list, or
; SS$_NORMAL if it is last.
MOVL SP,R11 ; create temporary stack pointer
MOVL SP,R10 ; save addr of first byte beyond list
MOVAQ DYNSTR,R9 ; keep desc addr handy
10$: ; BEGIN LOOP
PUSHL R9 ; pass addr of desc for returned string
PUSHAQ SEARCH_LIST_PARAM ; pass addr of parameter label desc
CALLS #2,G^CLI$GET_VALUE ; get next list item
BLBC R0,15$ ; if err, branch, return code
MOVL R0,R7 ; save status code
MOVL R9,R0 ; pass desc addr
JSB G^STR$ANALYZE_SDESC_R1 ; parse desc
SUBL R0,R11 ; allocate stack space for string
CVTWB R0,-(R11) ; store count at head of str
BICL3 #3,R11,SP ; realign stack
MOVC3 R0,(R1),1(R11) ; copy string to stack
CMPL R7,#SS$_NORMAL ; last item in list?
BNEQ 10$ ; no, branch, get another
BRB 20$ ; yes, EXIT LOOP
15$:
RET ; err exit
; Allocate dynamic buffers for lists and copy list from stack.
20$:
SUBL3 R11,R10,R2 ; find size of list
INCL R2 ; allow for end-of-list flag
MULL3 #2,R2,R1 ; get space for second list (upcase)
PUSHL R1 ; store byte count for pass by ref
PUSHAL SEARCH_LIST ; addr to return addr of VM alloc
PUSHAL 4(SP) ; addr of byte count
CALLS #2,G^LIB$GET_VM ;
BLBC R0,50$ ; if err, branch, return code
MOVL SEARCH_LIST,R3 ; retrieve addr of alloc
ADDL3 R2,R3,SEARCH_LIST_UPCASE; save addr of second list
DECL R2 ; no end-of-list flag on stack
MOVC3 R2,(R11),(R3) ; move list to newly allocated VM
CLRB (R3) ; end-of-list flag
; Read strings from first list buffer and upcase to second buffer
30$:
INSV #DSC$K_DTYPE_T,#16,#8,R7; prepare fixed string desc
INSV #DSC$K_CLASS_S,#24,#8,R7;
MOVL SEARCH_LIST,R6 ; get addr of original list
MOVL SEARCH_LIST_UPCASE,R8 ; get addr of upcase list to be
35$: ; BEGIN LOOP
MOVZBL (R6)+,R5 ; get byte count, point to string
BEQL 40$ ; end-of-list? yes, EXIT LOOP
MOVW R5,R7 ; transfer byte count to dst desc
MOVB R7,(R8)+ ; store dst byte count
MOVQ R5,-(SP) ; put src desc on stack
MOVQ R7,-(SP) ; put dst desc on stack
PUSHAQ 8(SP) ; pass addr of src desc
PUSHAQ 4(SP) ; pass addr of dst desc
CALLS #2,G^STR$UPCASE ; convert to uppercase
BLBC R0,50$ ; if err, branch, return code
ADDL #8*2,SP ; clean off descriptors
MOVAB (R6)[R5],R6 ; point to next src counted string
MOVAB (R8)[R5],R8 ; point to next dst loc
BRB 35$ ; END LOOP
40$:
CLRB (R8) ; end-of-list flag for upcase
MOVL #1,R0
50$:
RET
.PAGE
.SBTTL GETDEV
$CHFDEF
$DEVDEF
$SSDEF
$UCBDEF
$DEFINI DEV
$DEF DEV_L_EPID .BLKL 1
$DEF DEV_B_CLASS .BLKB 1
$DEF DEV_B_TYPE .BLKB 1
$DEF DEV_W_NAMELEN .BLKW 1
$DEF DEV_T_NAME .BLKB 16
DEV_S_NAME = .-DEV_T_NAME
DEV_K_SIZE = .
$DEFEND DEV
.PSECT DATA_WRT
NDEV:
.LONG 0
DEVLST:
.LONG DEV_K_SIZE*256
.LONG 0 ; addr obtained by LIB$GET_VM
;
; GETDEV
;
; Get info on next device of specified class.
;
; Arguments:
;
; index - device buffer index
; ptr - device buffer pointer
; pid - returned PID
; namelen - returned length of device name
; name - returned device name
; type - returned device type
; class - device class
;
DEV_INDEX = 4
DEV_PTR = 8
DEV_PID = 12
DEV_NAMELEN = 16
DEV_NAME = 20
DEV_TYPE = 24
DEV_CLASS = 28
.PSECT CODE
.ENTRY GETDEV,^M
MOVL NDEV,R8 ; get device count
BNEQ 30$ ; if zero, haven't yet generated list
PUSHAL DEVLST+4 ; arg2: addr for ret addr
PUSHAL DEVLST ; arg1: addr of byte count
CALLS #2,G^LIB$GET_VM ; allocate virtual memory for list
BLBS R0,10$ ; ok?
PUSHL R0 ; no, signal the error
CALLS #1,G^LIB$STOP
10$:
$CMKRNL_S -
ROUTIN=GETDEVLST,-
ARGLST=DEVLST
CMPL R0,#SS$_ACCVIO ; kernel mode access violation?
BNEQ 15$ ; no, branch
MOVO ACCVIO,-(SP) ; stack signal args
PUSHL R0 ; condition code
PUSHL #5 ; arg list header
MOVL SP,R0 ; get addr of arg list
$PUTMSG_S MSGVEC=(R0) ; write the message
$EXIT_S ; exit the image
15$:
CMPL R0,#SS$_NORMAL ; kernel mode routine exit ok
BEQL 20$ ; yes, branch
PUSHL R0 ; no, signal it
CALLS #1,G^LIB$STOP ; fatal
20$:
MOVL NDEV,R8
30$:
MOVL DEV_CLASS(AP),R2 ; get device class for which to search
MOVL DEV_INDEX(AP),R6 ; get dev buf index
MOVL DEV_PTR(AP),R7 ; get dev buf pointer
BNEQ 50$ ; if zero, must init both
SUBL3 #DEV_K_SIZE,DEVLST+4,R7 ; init addr one dummy block ahead of buf
CLRL R6 ; init index
BRB 50$
40$:
MOVAB DEV_K_SIZE(R7),R7 ; get addr of next block
CMPB DEV_B_CLASS(R7),R2 ; right class?
BNEQ 50$ ; no, go to end of loop
INCL TRMNO ; yes, keep count of this class
MOVL DEV_L_EPID(R7),R3 ; is the device being used?
BNEQ 60$ ; yes, exit loop, go copy out data
50$: AOBLEQ R8,R6,40$ ; no, loop for another block
MOVL #SS$_NOSUCHDEV,R0 ; fall through, no dev of this class
CLRQ DEV_INDEX(AP) ; clear index and pointer
RET
60$:
INCL TRMNOU ; keep count of dev in use of this class
MOVL R6,DEV_INDEX(AP) ; ret index
MOVL R7,DEV_PTR(AP) ; ret pointer
MOVL R3,@DEV_PID(AP) ; ret EPID
MOVZBL DEV_B_TYPE(R7),- ; ret type
DEV_TYPE(AP)
MOVQ @DEV_NAME(AP),R2 ; get output desc for device name
MOVZWL DEV_W_NAMELEN(R7),R0 ; get input str len
MOVAB DEV_T_NAME(R7),R1 ; get input str addr
CMPB (R1),#^A/_/ ; leading underscore?
BNEQ 70$ ; no, branch
INCL R1 ; yes, adjust addr to skip over
DECL R0 ; adjust count
70$:
MOVZWL R0,@DEV_NAMELEN(AP) ; ret name len
MOVC5 R0,(R1),#^A/ /,R2,(R3) ; copy device name
MOVL #SS$_NORMAL,R0
RET
;
; GETDEVLST
;
; Kernel mode routine to get a list of devices. The I/O database
; is locked by mutex so IPL is at AST level and page faults are allowed.
;
; AP - address of buffer descriptor
;
.ENTRY GETDEVLST,^M
MOVAB KRNLCH,(FP) ; establish cond hand to trap access vio
JSB G^SCH$IOLOCKR ; lock the I/O data base, IPL to AST lev
MOVQ (AP),R6 ; get buffer descriptor
CLRL R8 ; initialize device counter
CLRQ R10 ; init UCB, DDB ptrs for IOC$SCAN_IODB
PUSHL #SS$_NORMAL ; return code
10$:
JSB G^IOC$SCAN_IODB ; get UCB address
BLBC R0,30$ ; if zero, then no more devices
BBC #UCB$V_ONLINE,- ; skip offline device
UCB$L_STS(R10),10$
MOVL UCB$L_DEVCHAR(R10),R0
BBC #DEV$V_AVL,R0,10$ ; skip unavailable dev (redirected term)
BBS #DEV$V_MBX,R0,10$ ; skip mailbox device
MOVL #SS$_BUFFEROVF,R0 ; assume no room to copy data from UCB
SUBL #DEV_K_SIZE,R6 ; find actual buffer space available
BLSS 20$ ; if not enough, return with err code
MOVL UCB$L_PID(R10),R0 ; get internal PID of device owner
JSB G^EXE$IPID_TO_EPID ; translate to extended PID
MOVL R0,DEV_L_EPID(R7) ; save it (zero for nonexistent proc)
MOVB UCB$B_DEVCLASS(R10),- ; save device class
DEV_B_CLASS(R7)
MOVB UCB$B_DEVTYPE(R10),- ; save device type
DEV_B_TYPE(R7)
MOVL R10,R5 ; arg: UCB address
MOVL #2,R4 ; arg: op code
MOVAB DEV_T_NAME(R7),R1 ; arg: name buffer addr
MOVL #DEV_S_NAME,R0 ; arg: name buffer size
JSB G^IOC$CVT_DEVNAM ; get device name string
CMPL R0,#SS$_NORMAL ; did buffer overflow?
BNEQ 20$ ; yes, return with code
MOVW R1,DEV_W_NAMELEN(R7) ; no, store string count
MOVAB DEV_K_SIZE(R7),R7 ; point to next empty output data block
INCL R8 ; keep device count
BRB 10$ ; loop to get another device
20$:
MOVL R0,(SP) ; err, overwrite default return code
30$:
MOVL R8,NDEV ; save number of devices
MOVL G^SCH$GL_CURPCB,R4 ; get addr of PCB for unlock routine
JSB G^SCH$IOUNLOCK ; unlock I/O data base via mutex
POPL R0 ; get return code
RET
;
; KRNLCH
;
; Kernel mode condition handler.
;
.PSECT CODE,EXE,NOWRT,RD,BYTE,SHR,GBL
.ENTRY KRNLCH,^M
MOVL G^SCH$GL_CURPCB,R4 ; yes, get PCB addr for unlock
JSB G^SCH$IOUNLOCK ; unlock I/O mutex
SETIPL #0 ; reduce IPL from AST lev
MOVL CHF$L_SIGARGLST(AP),R6 ; get addr of signal arg list
CMPL CHF$L_SIG_NAME(R6),#SS$_ACCVIO ; is it access violation?
BNEQ 10$ ; no, branch
MOVO CHF$L_SIG_ARG1(R6),ACCVIO ; yes, save 4 args
10$:
PUSHL CHF$L_MCHARGLST(AP) ; addr of mech arg list
PUSHL R6 ; addr of sig arg list
CALLS #2,G^LIB$SIG_TO_RET ; return the condition code
RET
.PAGE
.SUBTITLE SUBROUTINES
;******************************************************************************
;****************************** GET_SUB_PIDS ******************************
;******************************************************************************
; This routine gets and queues up any PIDs of the "current" process's
; sub-processes. It also marks the "current" PID as "done".
GET_SUB_PIDS:
TSTL SUBNUM ; Any sub-procs?
BEQL 70$
MOVL #-1,WILDPID ; Yes, find it
10$: $GETJPI_S PIDADR=WILDPID,ITMLST=GETSUB
; Get owners of all processes
; (can use "normal" GETJPI
; since all info in PCB.)
CMPL #SS$_NORMAL,R0
BNEQ 70$ ; No more subs
CMPL OWNPID,PID ; Is it sub-process?
BNEQ 10$ ; No, get a new PID
30$: ADDL3 #16,#PIDQUE,R0 ; Insert in queue
40$: TSTL (R0) ; Find empty spot
BEQL 50$
ADDL2 #12,R0
BRB 40$
50$: MOVL RETPID,(R0) ; Fill it
INSQUE -8(R0),@PIDQUE+4 ; Queue it
60$: DECL SUBNUM
BNEQ 10$ ; Get more sub-proc's
70$: RSB
;******************************************************************************
;******************************** GET_BATCH *******************************
;******************************************************************************
GET_BATCH:
CALLS #0,QUI
RSB
;
; VMS V4.0 implementation
;
; This would be simple if the new system service $GETQUI had an argument
; or item list code to get the PID if a queue entry is executing.
; As it is, info is returned either for the requesting process, or for a named
; queue entry (which can be a wild card). (That is, it's easy to get the
; name of batch job's queue from inside the batch job, and it's easy to get
; a list of entry numbers and queue names for all executing batch jobs, but
; it's still a bit of a problem to get an entry number and queue name from a
; PID of an executing batch job.)
;
; The technique is to use $GETJPI in search mode to find the next
; executing batch job. Then a message is formatted and sent to JOB_CONTROL
; in the same manner as $GETQUI, except that the message includes the PID
; returned by $GETJPI for the batch job, instead of the current process's PID.
; This works because this message field (ACM$L_PID) is not used by JOB_CONTROL
; to determine who sent the message, but only to get queue info. The sender
; is determined from the PID returned in second longword of the IOSB on
; JOB_CONTROL's mailbox QIO.
;
$ACMDEF
$CHFDEF
$PCBDEF
$PHDDEF
$PSLDEF
$QUIDEF
; $ACM extensions
$DEFINI QUIACM
.=ACM$S_ACMDEF1+ACM$W_MSGSTS
$DEF ACM$L_IMAGCNT .BLKL 1 ; avoid IMGCNT, used in $ACMDEF
$DEF ACM$L_EFN .BLKL 1
$DEF ACM$A_IOSB .BLKL 1
$DEF ACM$L_ASTADR .BLKL 1
$DEF ACM$L_ASTPRM .BLKL 1
$DEF ACM$W_QUIFUNC .BLKW 1
$DEF ACM$L_QUILST
$DEFEND QUIACM
; Offsets in dynamically allocated storage
$DEFINI QUIBLK
$DEF QUI_L_EFN .BLKL 1 ; for pseudo-$GETQUI
$DEF QUI_Q_IOSB .BLKQ 1 ; for pseudo-$GETQUI
$DEF QUI_L_PID .BLKL 1 ; $GETJPI return item
$DEF QUI_L_STS .BLKL 1 ; $GETJPI return item
$DEF QUI_L_JPIPID .BLKL 1 ; $GETJPI search context
$DEF QUI_W_QUEUE_NAME_LEN .BLKW 1 ; pseudo-$GETQUI return item
$DEF QUI_T_QUEUE_NAME .BLKB 16 ; pseudo-$GETQUI return item
QUI_S_QUEUE_NAME = .-QUI_T_QUEUE_NAME
$DEF QUI_L_ENTRY_NUMBER .BLKL 1 ; pseudo-$GETQUI return item
$DEF QUI_W_MSG_LEN .BLKW 1 ; message sent to JOB_CONTROL
$DEF QUI_T_MSG .BLKB 255 ; requesting queue info
QUI_S_MSG = .-QUI_T_MSG
QUI_K_BLKSIZ = .
$DEFEND QUIBLK
.PSECT DATA_WRT,NOEXE,RD,WRT,LONG,NOSHR,GBL
QUI_A_BLK: ; address of dynamic storage
.BLKL 1
.PSECT CODE,EXE,NOWRT,RD,BYTE,SHR,GBL
.ENTRY QUI,^M
BBSS #ITM_V_BAT1,FLAGS2,10$ ; first time? no, branch
BSBW QUI_INIT ; alloc and init info blk
BLBS R0,5$ ; err? no, branch
BRW 40$ ; yes, return
5$:
MOVL #-1,QUI_L_JPIPID(R8) ; init $GETJPI search context
10$:
MOVL QUI_A_BLK,R8 ; get info blk addr
20$:
CLRQ -(SP) ; set up $GETJPI item list
PUSHAL QUI_L_PID(R8)
PUSHL #<!4> ; need PID
CLRL -(SP)
PUSHAL QUI_L_STS(R8)
PUSHL #<!4> ; need status to test for batch
MOVL SP,R7 ; save address of item list
30$:
$GETJPIW_S - ; get next process
PIDADR=QUI_L_JPIPID(R8),-
ITMLST=(R7)
BLBC R0,40$ ; branch if err
BBC #PCB$V_BATCH,QUI_L_STS(R8),30$ ; batch job? no, get another prc
MOVAB QUI_T_MSG(R8),R0 ; get msg addr
MOVL QUI_L_PID(R8),ACM$L_PID(R0) ; replace PID
BSBW QUI_SEND ; request info from job contrlr
BLBC R0,30$ ; err? yes, get another process
MOVL QUI_L_PID(R8),PID ; old WHERE code...
MOVL #255,LOCLEN
MOVAB LOCBUF,LOCLEN+4
MOVZWL QUI_W_QUEUE_NAME_LEN(R8),R0
MOVAB QUI_T_QUEUE_NAME(R8),R1
$FAO_S CTRSTR=BATCTR,-
OUTLEN=LOCLEN,-
OUTBUF=LOCLEN,-
P1=R0,P2=R1,-
P3=QUI_L_ENTRY_NUMBER(R8)
40$:
RET
;
; QUI_INIT
;
; Allocate and initialize queue info block (with the help of QUI_EXEC).
;
; Outputs:
;
; R0 - status
; R8 - addr of info block
; (R1 modified, all others restored)
;
; QUI_A_BLK - addr of info block
;
; Info block fields initialized.
;
QUI_INIT:
PUSHL #QUI_K_BLKSIZ ; number of bytes to alloc
PUSHAL QUI_A_BLK ; addr to receive addr of alloc
PUSHAL 4(SP) ; addr of byte count
CALLS #2,G^LIB$GET_VM ; allocate the buffer
SUBL3 #1,(SP)+,R1 ; pop len-1 (offset to end)
BLBC R0,20$ ; if error, branch
MOVL QUI_A_BLK,R8 ; get buf addr
ADDL3 R1,R8,-(SP) ; last addr in buf
PUSHL R8 ; first addr in buf
MOVL SP,R0 ; get addr of quadword arg
$LKWSET_S INADR=(R0) ; lock the page(s)
CLRQ (SP)+ ; clean arg from stack
BLBC R0,20$ ; if error, branch
PUSHAL QUI_L_EFN(R8) ; addr for returned EFN
CALLS #1,G^LIB$GET_EF ; alloc event flag
BLBC R0,20$ ; if error, branch
PUSHL R8 ; put addr of info block in arg list
MOVL SP,R0 ; save addr of arg list
$CMEXEC_S ROUTIN=QUI_EXEC,- ; initialize msg buf
ARGLST=(R0)
TSTL (SP)+ ; clean arg list from stack
BSBW QUI_TEST_ACCVIO ; handle access violation
BLBC R0,20$ ; branch if other err
MOVW R1,QUI_W_MSG_LEN(R8) ; save msg len
MOVL #SS$_NORMAL,R0 ;
20$:
RSB ;
;
; QUI_SEND
;
; Send message to job controller (with help of QUI_KERNEL) and wait for reply.
;
; Inputs:
;
; R8 - addr of info block
;
; Outputs:
;
; R0 - status
; (R1 modified, all others restored)
;
; Info block fields filled by job controller.
;
QUI_SEND:
CLRQ QUI_Q_IOSB(R8) ; initialize IOSB
$CLREF_S EFN=QUI_L_EFN(R8) ; clear event flag
BLBC R0,20$
PUSHAL QUI_T_MSG(R8) ; put msg addr in arg list
MOVZWL QUI_W_MSG_LEN(R8),-(SP) ; put msg len in arg list
MOVL SP,R0 ; get addr of arg lis
$CMKRNL_S - ; send it
ROUTIN=QUI_KERNEL,-
ARGLST=(R0)
BSBW QUI_TEST_ACCVIO ; handle access violation
BLBC R0,10$ ; branch if other err
$SYNCH_S - ; wait for completion
EFN=QUI_L_EFN(R8),-
IOSB=QUI_Q_IOSB(R8)
MOVZWL QUI_Q_IOSB(R8),R0 ; get status
10$:
CLRQ (SP)+ ; clean arg list from stack
20$:
RSB ; return with status
;
; QUI_EXEC
;
; Immitate the $GETQUI system service.
;
; The following code has been taken from EXE$GETQUI (module SYSSNDJBC of
; facility SYS). This was done to allow for an arbitrary value in field
; ACM$L_PID of the message which is sent the job controller. The job
; controller's QUI routines use this field to determine which process
; is making the request.
;
; Changing ACM$L_PID does not affect the interprocess communication because
; another value, ACM$L_PROCID, (the PID received by the job contrller in the
; second longword of the IOSB on its mailbox read QIO) is used to identify the
; process to which the completion AST should be queued. (ACM$L_PROCID is an
; offset of -4 from the message buffer, which is valid if the buffer is
; appended to the IOSB.)
;
; The message fields are filled below using auto-increment addressing, but
; they can also be referenced by ACM$ offsets (with the extensions specified
; above). The arguments for the $GETQUI service are appended after the
; standard fields.
;
; Inputs:
;
; (AP) addr of buffer
;
; Outputs:
;
; R0 status code
; R1 number of bytes written to the buffer
;
.ENTRY QUI_EXEC,^M
MOVAB QUI_HANDLER,(FP) ; prevent process termination
; on err
MOVL @#CTL$GL_PCB,R6 ; get this process's PCB addr
MOVL @#CTL$GL_PHD,R7 ; get P1 region addr of PHD map
MOVL (AP),R8 ; get addr of data block
MOVAB QUI_T_MSG(R8),R3 ; get msg addr
MOVZWL #MSG$_GETQUI,(R3)+ ; ACM$W_TYPE, ACM$W_MAILBOX
MOVQ PHD$Q_PRIVMSK(R7),(R3)+ ; ACM$Q_PRVMSK
MOVL PCB$L_UIC(R6),(R3)+ ; ACM$L_UIC
MOVC3 #20,@#CTL$T_USERNAME,(R3) ; ACM$T_USERNAME, ACM$T_ACCOUNT
SUBB3 PCB$B_PRIB(R6),#31,(R3)+ ; ACM$B_PROCPRI
MOVPSL R0 ; get PSL
EXTZV #PSL$V_PRVMOD,- ; get previous mode
#PSL$S_PRVMOD,R0,R0
MOVB R0,(R3)+ ; insert in buf
CLRW (R3)+ ; unused
MOVL PCB$L_EPID(R6),(R3)+ ; ACM$L_PID
MOVL PCB$L_STS(R6),(R3)+ ; ACM$L_STS
MOVL PCB$L_EOWNER(R6),(R3)+ ; ACM$L_OWNER
MOVQ PCB$T_TERMINAL(R6),(R3)+ ; ACM$T_TERMINAL
10$:
MOVQ G^EXE$GQ_SYSTIME,(R3) ; ACM$Q_SYSTIME
CMPL G^EXE$GQ_SYSTIME,(R3) ; validate system time
BNEQ 10$
CMPL G^EXE$GQ_SYSTIME+4,4(R3)
BNEQ 10$
ADDL #8,R3 ; size of system time
; The following ACM$ extension comprises the $GETQUI arguments
; (with the exception of image count, which is used by the return kernel mode
; AST to determine whether the same image is executing as that which initiated
; the request).
;
; Note that the order of item code and size are reversed from the standard
; system service item list format. The input item is passed by value.
MOVL PHD$L_IMGCNT(R7),(R3)+ ; image count
MOVZBL QUI_L_EFN(R8),(R3)+ ; event flag
MOVAQ QUI_Q_IOSB(R8),(R3)+ ; I/O status block
CLRQ (R3)+ ; astadr, astprm
MOVW #QUI$_DISPLAY_JOB,(R3)+ ; function code
MOVW #QUI$_SEARCH_FLAGS,(R3)+ ; input item code
MOVW #4,(R3)+ ; input item size
MOVL #QUI$M_SEARCH_THIS_JOB,(R3)+ ; input item value
MOVW #QUI$_ENTRY_NUMBER,(R3)+ ; item code
MOVW #4,(R3)+ ; item size
MOVAL QUI_L_ENTRY_NUMBER(R8),(R3)+ ; item return address
CLRL (R3)+ ; item return size address
MOVW #QUI$_QUEUE_NAME,(R3)+ ; item code
MOVW #16,(R3)+ ; item size
MOVAB QUI_T_QUEUE_NAME(R8),(R3)+ ; item return address
MOVAW QUI_W_QUEUE_NAME_LEN(R8),(R3)+ ; iterm return size address
MOVAB QUI_T_MSG(R8),R1 ; get msg starting addr
SUBL3 R1,R3,R1 ; compute and return len
MOVL #SS$_NORMAL,R0
RET
;
; QUI_KERNEL
;
; Invoke system routine to send message to job controller's mailbox.
;
.ENTRY QUI_KERNEL,^M
MOVAB QUI_HANDLER,(FP) ; prevent fatal machine check
; while IPL is ASTDEL or less
MOVQ (AP),R3 ; R3 = msg len, R4 = addr of msg buf
MOVAB G^SYS$GL_JOBCTLMB,R5 ; addr of UCB for job contrlr's mailbox
JSB G^EXE$SENDMSG
RET
;
; QUI_HANDLER
;
; Handle executive and kernel mode conditions by returning a status code
; to the user mode routine that called the establisher. If access violation,
; save the four signal args (mask, virt addr, PC, PSL) so a complete message
; can be issued by the user mode routine.
;
.ENTRY QUI_HANDLER,0
MOVL CHF$L_SIGARGLST(AP),R0 ; get addr of signal arg list
CMPL CHF$L_SIG_NAME(R0),#SS$_ACCVIO ; access violation?
BNEQ 10$ ; no, branch
MOVO CHF$L_SIG_ARG1(R0),ACCVIO ; yes, save 4 args
10$:
PUSHL CHF$L_MCHARGLST(AP) ; pass addr of mech arg list
PUSHL R0 ; pass addr of sig arg list
CALLS #2,G^LIB$SIG_TO_RET ; return to caller of establishr
RET
;
; QUI_TEST_ACCVIO
;
; Tests for access violations. If R0 contains SS$_ACCVIO, the four signal args
; are copied from ACCVIO, a message is generated, and the image is terminated.
; Any other value in R0 causes immediate return with no registers modified.
;
; Intended to be called in user mode following return from inner mode routine
; that establishes QUI_HANDLER as its condition handler.
;
QUI_TEST_ACCVIO:
CMPL R0,#SS$_ACCVIO ; access violation?
BNEQ 10$ ; no, other err, branch
MOVO ACCVIO,-(SP) ; push four signal args
PUSHL R0 ; condition code
PUSHL #5 ; arg list header
MOVL SP,R0 ; get addr of arg list
$PUTMSG_S MSGVEC=(R0) ; write the message
$EXIT_S ; terminate the image
10$:
RSB
;******************************************************************************
;********************************* GET_REST *******************************
;******************************************************************************
; This routine gets non-terminal connected jobs
GET_REST:
10$: $GETJPI_S PIDADR=RESTPID,ITMLST=GETPID
; Get owners of all processes
; (can use "normal" GETJPI
; since all info in PCB.)
BLBC R0,40$ ; No more PIDS
MOVAL DONEPIDS,R0 ; Check to see if we've done
20$: TSTL (R0) ; this one
BEQL 30$
CMPL PID,(R0)+
BEQL 10$ ; Yes, get another
BRB 20$
30$: MOVL #1,R0 ; No, do it
40$: RSB
;******************************************************************************
;******************************* GET_DEVICES ******************************
;******************************************************************************
; This routine gets allocated devices of the type pushed on the stack
; prior to the call.
GET_DEVICES:
MOVL #1,DDB_ARG ; First DDB
CLRL UCB_ARG
10$:
CALLG GETDEVARG,GETDEV
BLBS R0,20$ ; Get an allocated device
RSB
20$: MOVAW BADDEV,R0 ; Check for unwanted devices
30$: TSTW (R0)
BEQL 40$
CMPW (R0)+,TRMBUF
BEQL 10$
BRB 30$
40$: MOVC5 #0,USRNAM,#BLANK,#12,USRNAM
; Clear username
$GETJPI_S PIDADR=PID,ITMLST=GETUSR
; Get Username (regular
; GETJPI since in PCB/JIB)
$FAO_S CTRSTR=MTACTR,- ; Format string
OUTLEN=OUTRAB+RAB$W_RSZ,OUTBUF=RECDSC,-
P1=TRMLEN,P2=#TRMBUF,P3=#12,P4=#USRNAM
$PUT RAB=OUTRAB ; Output string
BRW 10$ ; Loop
;******************************************************************************
;******************************** INIT_SORT *******************************
;******************************************************************************
; This routine initializes the area used to sort records.
INIT_SORT:
PUSHL #64*KEY_LEN ; Room for 64 keys
PUSHAL SORT_DATA ; Get a bunch of memory
PUSHAL 4(SP)
CALLS #2,G^LIB$GET_VM
MOVL SORT_DATA,NEXT_SKEY ; Spot for first key
ADDL2 #4,SP
RSB
;******************************************************************************
;******************************* RELEASE_REC ******************************
;******************************************************************************
; This routine stores away a record to be sorted. It also constructs
; its key. Sorting will be by username->terminal->process name
RELEASE_REC:
PUSHR #^M
MOVC5 USRLEN,USRNAM,#BLANK,- ; Move in username
#USR_BUF_LEN,@NEXT_SKEY
ADDL2 #USR_BUF_LEN,NEXT_SKEY
MOVC5 TRMLEN,TRMBUF,#BLANK,- ; Move in terminal
#TERM_BUF_LEN,@NEXT_SKEY
ADDL2 #TERM_BUF_LEN,NEXT_SKEY
MOVC5 PRCLEN,PRCNAM,#BLANK,- ; Move process name
#PRC_BUF_LEN,@NEXT_SKEY
ADDL2 #PRC_BUF_LEN,NEXT_SKEY
MOVZWL RECLEN,-(SP) ; Get room for record
ADDL2 #2,(SP)
PUSHAL @NEXT_SKEY
PUSHAL 4(SP)
CALLS #2,G^LIB$GET_VM
ADDL2 #4,SP
MOVL @NEXT_SKEY,R0
ADDL2 #4,NEXT_SKEY
MOVW RECLEN,(R0)+ ; Store record length
MOVC3 RECLEN,RECBUF,(R0) ; Store record
POPR #^M
RSB
;******************************************************************************
;******************************** SORT_MERGE ******************************
;******************************************************************************
; This routine sorts the records and outputs them in order.
;
; The routine used is a modified QUICKSORT using detached key records.
; The modifications are:
; 1.) The lower valued partition (partition which is below
; (by order) the pivot) is chosen for a next phase (the
; higher is stacked) of processing, rather than smaller
; (size). This allows completed partitions to be
; directly output.
; 2.) The pivot is included in the lower valued partition
; (so it can be output).
; Pivot selection is done using Singleton's method (median of first,
; last, and middle keys). Partitions of 7 or less elements are
; considered sorted and are passed to a final SIFT phase from which
; they are output.
SORT_MERGE:
PUSHR #^M
CMPL SORT_DATA,NEXT_SKEY ; Check for no records
BNEQ 5$
BRW 65$
5$: MOVL SORT_DATA,R6 ; R6 = first pointer
SUBL3 #KEY_LEN,NEXT_SKEY,R7 ; R7 = end pointer
PUSHL #0 ; Mark end of partition stack
PUSHL #0
10$: MOVQ R6,R8 ; Save ends
SUBL3 R6,R7,R0 ; Check for partition size
BEQL 60$ ; One item partition
CMPL #7*KEY_LEN,R0
BGEQU 15$
BRW 70$
; SIFT sort for partitions of less than 8 items
15$: ADDL3 #KEY_LEN,R6,R7
20$: CMPC3 #KEY_LEN-4,(R6),(R7) ; Compare keys
BLSSU 50$
; Sift
MOVC3 #KEY_LEN,(R7),KEYBUF
MOVC3 #KEY_LEN,(R6),(R7)
30$: CMPL R6,R8 ; Hit top
BEQL 40$
CMPC3 #KEY_LEN-4,-KEY_LEN(R6),KEYBUF
BLSSU 40$
MOVC3 #KEY_LEN,-KEY_LEN(R6),(R6)
SUBL2 #KEY_LEN,R6
BRB 30$
40$: MOVC3 #KEY_LEN,KEYBUF,(R6) ; Found key position
50$: MOVL R7,R6 ; Get new keys
ADDL2 #KEY_LEN,R7
CMPL R6,R9
BNEQ 20$
; Output sift results
60$: MOVL KEY_LEN-4(R8),R6 ; Get a record address
MOVW (R6)+,
MOVL R6,
$PUT RAB=OUTRAB ; Output it
ADDL2 #KEY_LEN,R8
CMPL R8,R9
BLEQU 60$
POPL R7 ; Get a new partition
POPL R6
BEQL 65$
BRW 10$
65$: POPR #^M
MOVAL RECBUF,
RSB ; None, then we are done
; QUICKSORT
70$: SUBL3 R6,R7,R6 ; Get middle key location
DIVL2 #2*KEY_LEN,R6
MULL2 #KEY_LEN,R6
ADDL2 R8,R6
CMPC3 #KEY_LEN-4,(R8),(R6) ; Sift first, middle, and last
BLSSU 80$
MOVC3 #KEY_LEN,(R8),KEYBUF
MOVC3 #KEY_LEN,(R6),(R8)
MOVC3 #KEY_LEN,KEYBUF,(R6)
80$: CMPC3 #KEY_LEN-4,(R6),(R7)
BLSSU 90$
MOVC3 #KEY_LEN,(R7),KEYBUF
MOVC3 #KEY_LEN,(R6),(R7)
CMPC3 #KEY_LEN-4,(R8),KEYBUF
BLSSU 100$
MOVC3 #KEY_LEN,(R8),(R6)
MOVC3 #KEY_LEN,KEYBUF,(R8)
90$: MOVC3 #KEY_LEN,(R6),KEYBUF ; Take middle as pivot
100$: MOVC3 #KEY_LEN,KEY_LEN(R8),(R6)
ADDL3 #KEY_LEN,R8,R6 ; R6 is low empty
105$: SUBL2 #KEY_LEN,R7 ; R7 will be high
110$: CMPC3 #KEY_LEN-4,KEYBUF,(R7) ; Find high empty
BGTRU 120$
SUBL2 #KEY_LEN,R7
BRB 110$
120$: CMPL R6,R7 ; Make sure we aren't done
BGTRU 160$
MOVC3 #KEY_LEN,(R7),(R6) ; Fill low empty
ADDL2 #KEY_LEN,R6 ; and find a new one
130$: CMPC3 #KEY_LEN-4,KEYBUF,(R6)
BLSSU 140$
ADDL2 #KEY_LEN,R6
BRB 130$
140$: CMPL R6,R7 ; Make sure we aren't done
BGTRU 150$
MOVC3 #KEY_LEN,(R6),(R7) ; Fill high empty
BRB 105$ ; and continue
150$: MOVL R7,R6
160$: MOVC3 #KEY_LEN,KEYBUF,(R6) ; Done! Move pivot in
PUSHAL KEY_LEN(R6) ; Push high partition on stack
PUSHL R9
MOVL R6,R7
MOVL R8,R6
BRW 10$
.PAGE
.SBTTL DATA
.PSECT DATA_WRT,LONG,NOEXE,RD,WRT,NOSHR,GBL
; RMS data structures
.ALIGN LONG
PORTFAB:
$FAB FAC=GET
RMS_FNM FAB=PORTFAB,FNM=
PORTRAB:
$RAB FAB=PORTFAB,UBF=LOCBUF,USZ=255
SYSOUT: $FAB FAC=PUT,RAT=CR
RMS_FNM FAB=SYSOUT,FNM=
OUTRAB: $RAB FAB=SYSOUT,RBF=HDRBUF
.PSECT DATA_RD,BYTE,RD,NOWRT,NOEXE,SHR,GBL
; Read only structures
ALLOC: .ASCII \(Alloc)\ ; Allocated message
ALLOCL=.-ALLOC
AMBIG_CTR: ; FAO string for ambiguous switch msg.
.ASCID \Ambiguous keyword !AD encountered, !AC assumed\
BAD_SYNTAX_CTR: ; FAO string for bad search string
.ASCID \!AS is invalid syntax.\
BADDEV: ; List of device types not to include
; in allocation list
.WORD ^A\XM\ ; DECNET
.WORD ^A\DR\ ; Standard disk
.WORD ^A\DB\ ; Standard disk
.WORD ^A\NE\ ; More DECNET
.WORD ^A\XE\ ; Yet more DECNET
.WORD ^A\PT\ ; MODEL Windows
.WORD ^A\XG\ ; Some CERN-DD garbage
.WORD ^A\LN\ ; LN03's
.WORD 0
BADPRCNAM: ; List of process names not to be
; output
; .ASCIC \NETACP\
.BYTE 0
BADUSRNAM: ; List of usernames not to be output
.ASCIC \JOB_CONTROL\ ; Job controller
.BYTE 0
BATCTR:
.ASCID \queue !AF, entry !UL\ ; Batch queue location FAO control str
GETPID: ; GETJPI list to get non-term. PIDs
.WORD 4,JPI$_PID
.ADDR PID
.LONG 0,0
GETSUB: ; GETJPI list to get owner PID
.WORD 4,JPI$_PID ; PID
.ADDR RETPID
.LONG 0
.WORD 4,JPI$_OWNER ; OWNER PID
.ADDR OWNPID
.LONG 0,0
GETUSR: ; GETJPI list to get username
.WORD 12,JPI$_USERNAME
.ADDR USRNAM
.ADDR USRLEN
.LONG 0
LONG_CPU_FAO: ; FAO call list for long CPU time
$FAOL CTRSTR=LONG_TIME_CTR,OUTBUF=CPUDSC,PRMLST=TIME_PLIST
LONG_ELAP_FAO: ; FAO call list for long elapsed time
$FAOL CTRSTR=LONG_TIME_CTR,OUTBUF=TIMEDSC,PRMLST=TIME_PLIST
LONG_TIME_CTR: ; Long Time FAO control string
.ASCID \!3UL:!2ZL:!2ZL.!1ZL\
MOVTC_TAB: ; Table for MOVTC
ASCII_TAB <<0-31>,<127-255>>,<.>
FILL_CHAR=^A\.\
MTACTR: .ASCID \!AD is in use by !AD\ ; Device allocation FAO control string
NO_SWIT_CTR: ; String for no match message
.ASCID \!AS not a valid switch.\
NO_USR: .ASCII \No info \ ; No username message
NO_USR_LEN=.-NO_USR
NOCPU: .ASCII \ NO INFO\ ; No CPU info. message
NO_NUMBER: ; No info. message
.ASCII \ NO INF\
PHMEM_LIST: ; Arg. list for OTS$CVT_L_TI
.LONG 3
.ADDR PHYS_MEM
.ADDR TMPDSC
.LONG 1
PHMEM_NO: ; No info. message
.ASCII \NONE\
PID_LIST: ; Argument list for OTS$CVT_L_TZ call
.LONG 3 ; by PID output routine
.ADDR PID
.ADDR TMPDSC
.LONG 8
PRIO_CTR: ; Priority FAO control string
.ASCID \!2UL/!2\
PRIO_NO: ; No info message
.ASCII @ ?/? @
RECDSC: .LONG 256 ; Output record descriptor
.ADDR RECBUF
RT_LOC: .ASCII \Remote node\ ; RTxn type locations
RT_LOC_LEN=.-RT_LOC
RT_TYPE=^A\RT\
SHORT_CPU_CTR: ; Short CPU time FAO control string
.ASCID \!3UL:!2ZL.!1ZL\
SHORT_CPU_FAO: ; FAO call list for short CPU
$FAOL CTRSTR=SHORT_CPU_CTR,OUTBUF=CPUDSC,PRMLST=TIME_PLIST
SHORT_ELAP_CTR: ; Short elapsed time FAO control string
.ASCID \!4UL:!2ZL\
SHORT_ELAP_FAO: ; FAO call list for short elapsed time
$FAOL CTRSTR=SHORT_ELAP_CTR,OUTBUF=TIMEDSC,PRMLST=TIME_PLIST
STATE_TAB: ; State types
STATETYP ,
STATETYP CEF
STATETYP COLPG
STATETYP COM
STATETYP COMO
STATETYP CUR
STATETYP FPG
STATETYP HIB
STATETYP HIBO
STATETYP LEF
STATETYP LEFO
STATETYP MWAIT
STATETYP PFW
STATETYP SUSP
STATETYP SUSPO
TRIM_LIST: ; Argument lists for calls to STR$TRIM
.LONG 3
.ADDR TMPDSC
.ADDR TMPDSC
.ADDR TMPDSC
TRIM_LIST_2:
.LONG 3
.ADDR RECLEN
.ADDR RECLEN
.ADDR RECLEN
TRMCTR: .ASCID \!AC!UW:\ ; Terminal FAO control string
TRMDSC: .LONG TERM_BUF_LEN ; Terminal name descriptor
.ADDR TRMBUF
VT_TYPE=^A\VT\
; Summary line FAO control strings
SUMCTR:
.ASCID \ !+!SL/!SL terminals in use at !+!%T\
SUMCTR_NODE:
.ASCID \ !+!SL/!SL terminals in use on node !AS at !%T\
SUMCTR_MATCH:
.ASCID \ !SL matches with !SL/!SL terminals in use at !+!%T\
SUMCTR_MATCH_NODE:
.ASCID \ !SL matches with !SL/!SL terminals in use on node !AS at !%T\
SYSNODE: ; Current node logical name
.ASCID \SYS$NODE\
TRMTAB: ; terminal types
TTYTYP UNKNOWN
TTYTYP VT05
TTYTYP VK100
TTYTYP VT173
TTYTYP TQ_BTS
TTYTYP TEK401X
TTYTYP FT1,I100
TTYTYP FT2,
TTYTYP FT3,ADDS100
TTYTYP FT4,
TTYTYP FT5,
TTYTYP FT6,
TTYTYP FT7,
TTYTYP FT8,
TTYTYP LA36
TTYTYP LA120
TTYTYP LA34
TTYTYP LA38
TTYTYP LA12
TTYTYP LA100
TTYTYP LA24
TTYTYP LN03
TTYTYP LQP02
TTYTYP LA84
TTYTYP VT52
TTYTYP VT55
TTYTYP VT100
TTYTYP VT101
TTYTYP VT102
TTYTYP VT105
TTYTYP VT125
TTYTYP VT131
TTYTYP VT132
TTYTYP VT200_Series,VT200
TTYTYP Pro_Series,PRO
TRMTABLEN=.-TRMTAB/4 ; save upper limit
BATTRM=.-TRMTAB/4 ; Batch type
.SAVE_PSECT
.PSECT STRINGS,BYTE,RD,NOWRT,NOEXE,SHR,GBL
10$: .ASCIC /BATCH/
.RESTORE_PSECT
.ADDR 10$
SUBTRM=.-TRMTAB/4 ; Subprocess type
.SAVE_PSECT
.PSECT STRINGS,BYTE,RD,NOWRT,NOEXE,SHR,GBL
20$: .ASCIC /SUB-PRC/
.RESTORE_PSECT
.ADDR 20$
UIC_CTR: ; Control string for UIC
.ASCID \[!3OW,!3OW]\
UIC_NONE:
.ASCII \[ NO UIC]\ ; Message with no UIC
WSET_LIST: ; Arg. list for OTS$CVT_L_TI
.LONG 3
.ADDR WORK_SET
.ADDR TMPDSC
.LONG 1
WSET_NO: ; No info. message
.ASCII \NONE\
.PSECT DATA_WRT,LONG,NOEXE,RD,WRT,NOSHR,GBL
; Read/Write data areas
ACCVIO:
.BLKW 8 ; for handlers to save accvio sig args
CUR_TIME: ; Current system time
.QUAD
DONEPIDS: ; PIDs already processed
; .LONG 0[96]
.LONG 0[192]
DONEPIDS_LEN=.-DONEPIDS
FNDNUM: .LONG 0 ; Number of search matches
FLAGS: .LONG 0
FLAGS2: .LONG 0
GETDEVARG:
.LONG 7 ; # of args
DDB_ARG: .LONG 1 ; Indicate first pass through
; (system addrs negative)
UCB_ARG: .LONG 0 ; For UCB
.ADDR PID ; And pid
.ADDR TRMLEN ; For terminal length
.ADDR TRMDSC ; For terminal name
TYPE_ARG: .LONG 0 ; For terminal type
CLASS_ARG: .LONG DC$_TERM ; Specify looking for terminal
JPILST: ; GETJPI list for everything
.WORD USR_BUF_LEN,JPI$_USERNAME ; Username
.ADDR USRNAM
.ADDR USRLEN
.WORD TERM_BUF_LEN,JPI$_TERMINAL ; Login terminal
.ADDR LGNTRM
.ADDR LGNTRML
.WORD PRC_BUF_LEN,JPI$_PRCNAM ; Process name
.ADDR PRCNAM
.ADDR PRCLEN
.WORD 4,JPI$_PRCCNT ; # sub-processes
.ADDR SUBNUM
.LONG 0
.WORD 4,JPI$_OWNER ; Process owner
.ADDR OWNER_PID
.LONG 0
.WORD IMAG_BUF_LEN,JPI$_IMAGNAME ; Executing image
.ADDR IMGNAM
.ADDR IMGLEN
GETJPI_END:
.LONG 0[<2*11>+1]
.WORD 0[2*11]
HDRBUF: .BLKB 256 ; Title buffer
KEYBUF: .BLKB KEY_LEN ; Working storage for sort
LOCBUF: .BLKB 256 ; Location buffer
LOCLEN: .LONG 0 ; Location descriptor
.ADDR LOCBUF
LSTPID: .ADDR DONEPIDS ; Next open position in DONEPIDS
MAP_PAGES: ; Pages global section mapped to
.BLKQ 2
NEXT_SKEY:
.LONG ; Next available sort key postion
NODE: .LONG 64 ; Node name descriptor
.ADDR .+4
.BLKB 64
NUMBER_LIST: ; Argument list for OTS$CVT_L_TI call
.LONG 3
.BLKL 1
.ADDR TMPDSC
.LONG 1
OWNPID: .LONG 0 ; Process owner PID
PID: .BLKL 1 ; PID
PIDQUE: .ADDR PIDQUE ; Queue of sub-proc PID's
.ADDR PIDQUE
; .BLKL 96*3 ; Will hold 96
.BLKL 192*3 ; Will hold 192
PORTPASS: ; Count of passes through port file
.BLKL 1
RECBUF: .BLKB 256 ; Output record buffer
RECLEN: .LONG 256 ; Output record length
.ADDR RECBUF
RECUPP: .LONG 256 ; Upper case record
.ADDR .+4
.BLKB 256
RESTPID:
.LONG -1 ; Wild card PID for non-term. jobs
RETPID: .BLKL 1 ; Return PID (for subprocs)
SORT_DATA: ; Start of sort virtual memory
.LONG
TIME_PLIST: ; FAO param. list for times
.BLKL 4
TMPDSC: .BLKL 2 ; Space for a temporary descriptor
TRMLEN: .LONG 0 ; Terminal name length
.ADDR TRMBUF
TRMBUF: .BYTE BLANK[TERM_BUF_LEN] ; Terminal name buffer
TRMNO: .LONG 0 ; Total number of terminals
TRMNOU: .LONG 0 ; Number of terminals in use
USR_FIELD_END: ; End of username output
.LONG 0
USR_FIELD_LEN: ; Length of username output
.LONG 0
WILDPID: ; Wildcard PID
.LONG -1
VALUE_BUF: ; All things which should be initialized before GETJPI
BASE_PRIO:
.LONG 0 ; Process base priority
BUF_IO: .LONG 0 ; Buffered I/O count
CPUDSC: .LONG 8 ; Descriptor for CPU time
.ADDR .+4
CPUSTR: .BYTE BLANK[11] ; Buffer for CPU time formatting
CPUTIM: .LONG 0 ; CPU time
DIR_IO: .LONG 0 ; Direct I/O count
IMGLEN: .LONG 0 ; Image name length
.ADDR IMGNAM
IMGNAM: .BYTE BLANK[IMAG_BUF_LEN] ; Image name buffer
LGNTRML: ; Login terminal length
.LONG 0
.ADDR LGNTRM
LGNTRM: .BYTE BLANK[TERM_BUF_LEN] ; Login terminal
LOGIN_TIME: ; Login time
.QUAD 0
OWNER_PID: ; Process owner PID
.LONG 0
PAGE_FLTS:
.LONG 0 ; Page faults
PHYS_MEM: ; Pages in memory
.LONG 0
PRCLEN: .LONG 0 ; Process name length
.ADDR PRCNAM
PRCNAM: .BYTE BLANK[PRC_BUF_LEN] ; Process name buffer
PRIO: .LONG 0 ; Process priority
STATE: .LONG 0 ; State
SUBNUM: .LONG 0 ; Number of sub processes
TIMEDSC: ; Descriptor for elapsed time
.LONG 7
.ADDR TIMESTR
TIMESTR: ; Buffer for elapsed time
.BYTE BLANK[11]
UIC: .LONG 0 ; Process UIC
USRLEN: .LONG 0 ; Username length
.ADDR USRNAM
USRNAM: .BYTE BLANK[USR_BUF_LEN+PRC_BUF_LEN+3]
; Username buffer
WORK_SET:
.LONG 0 ; Working set size
VALUE_BUF_LEN=.-VALUE_BUF
MASTER_BUF: ; Copy of VALUE_BUF
.BLKB VALUE_BUF_LEN
.PAGE
.SBTTL OUTPUT TABLES
;
; This is the area in which all flags are defined and output
; routines included.
;
; Each flag should have a call to OUTTAB macro to define it (this
; will define ITM_V_name and ITM_M_name (offset and mask)). For output
; flags the following additional information is required by the OUTTAB
; macro:
; HEAD - Title of the output field. This is included
; on the header line. If the output field has
; a leading blank the character BLANK_FILL should
; be used instead.
; HEAD_LONG - Title of the output field with "long" output.
; (will default to HEAD if not included)
; JPI - GETJPI symbol to be included in GETJPI list
; (JPI$_'JPI'). (optional)
; JPISIZ - Size of buffer for GETJPI information.
; (defaults to 4)
; JPIBUF - Buffer for GETJPI information. (required if
; JPI present)
; JPILEN - Longword to return length of JPIBUF used.
; (defaults to 0 (no return))
; JPI2 - Same as JPI but for a second value. (optional)
; JPISIZ2 - Size of buffer for GETJPI information.
; (defaults to 4)
; JPIBUF2 - Buffer for GETJPI information. (required if
; JPI2 present)
; JPILEN2 - Longword to return length of JPIBUF2 used.
; (defaults to 0 (no return))
;
; For flags dealing with command switches the following is used.
; SWITCH - TPARSE switch to be included for this item.
;
; After the call to OUTTAB for an output flag one should use the macro
; OUTRTN to establish the start of an output routine. Include the
; routine, and terminate it with a call to ENDRTN. These routines
; will add output to the output buffer. They should consist of a single
; entry and exit (top to bottom). They may use all registers but FP and
; SP must be restored to their original position, and AP contains the
; address of the next available byte in the output buffer and should
; be updated by the routine. Each routine can be considered as its
; own local block for local lable purposes.
;
; The flag ITM_V_LONG will be set in FLAGS for long format output.
; The flag ITM_V_FIRST will be set in FLAGS2 for the first output field.
;
; The macro INSERT_BLANK can be used to insert an optional leading blank
; (left out only if the field is the first one).
;
; The macro ALLOCATED causes a branch to the indicated label if the
; terminal is not allocated or there is no login terminal. If any
; parameter is included for NOT the opposite will occur (branch if
; the terminal IS allocated AND there is a login terminal. Format is:
; ALLOCATED LABEL[,NOT]
BLANK_FILL= ^A\~\ ; Character to indicate leading blank
; Flags for the various items, and output formats
OUTTAB INT,SWITCH=INTERACTIVE ; /INTERACTIVE
OUTTAB BAT,SWITCH=BATCH ; /BATCH
OUTTAB SORT,SWITCH=SORT ; /SORT
OUTTAB SUB,SWITCH=SUBPROCESSES ; /SUBPROCESSES
MULTI_SWITCH FLAGS=ITM_M_BAT!ITM_M_SUB!ITM_M_SORT!ITM_M_INT,-
SWITCH=FULL
OUTTAB TYPE=PID,HEAD=<~ PID >,SWITCH=PID ; /PID
OUTRTN PID
INSERT_BLANK
MOVL #8,TMPDSC ; Convert to hex
MOVL AP,
CALLG PID_LIST,G^OTS$CVT_L_TZ
ADDL2 #8,AP ; Update AP
ENDRTN PID
OUTTAB TYPE=USER,HEAD=<~Username>,- ; /USERNAME
HEAD_LONG=<~Username >,SWITCH=USERNAME
OUTRTN USER
INSERT_BLANK
MOVL USRLEN,R7
BEQL 10$
MOVL R7,TMPDSC
MOVAB USRNAM, ; Trim user name
CALLG TRIM_LIST,G^STR$TRIM
MOVZWL TMPDSC,R7
MOVL R7,USR_FIELD_LEN
BEQL 10$
BRB 20$
10$: MOVZWL #NO_USR_LEN,R7 ; No info.
MOVC3 #NO_USR_LEN,NO_USR,USRNAM
MOVL R7,USR_FIELD_LEN
20$: MOVZWL #8,R6 ; Set field length
BBS #ITM_V_LONG,FLAGS,25$
CMPL #8,USR_FIELD_LEN
BGEQ 30$
MOVZWL #8,USR_FIELD_LEN
BRB 30$
25$: MOVZWL #12,R6
CMPL #12,USR_FIELD_LEN
BGEQ 30$
MOVZWL #12,USR_FIELD_LEN
30$: MOVC5 R7,USRNAM,#BLANK,R6,(AP) ; Move string
ADDL3 AP,USR_FIELD_LEN,USR_FIELD_END
ADDL2 R6,AP
ENDRTN USER
OUTTAB TYPE=PROC,HEAD=<~(proc) >,- ; /PROCESS_NAME
HEAD_LONG=<~(process name) >,-
SWITCH=PROCESS_NAME
OUTRTN PROC
BBC #ITM_V_USER,FLAGS,10$ ; Concatenate to user
CMPL USR_FIELD_END,AP
BGEQ 10$
MOVL USR_FIELD_END,AP
10$: INSERT_BLANK
MOVW PRCLEN,TMPDSC
BEQL 20$
MOVAB PRCNAM, ; Trim process name
CALLG TRIM_LIST,G^STR$TRIM
MOVW TMPDSC,PRCLEN
BEQL 20$
CMPC5 USRLEN,USRNAM,#BLANK,PRCLEN,PRCNAM
BEQL 20$ ; Include process name?
CMPB #^A\_\,PRCNAM
BNEQ 30$
CMPL #^A\_JOB\,PRCNAM
BEQL 20$
CMPL ,TRMBUF
BNEQ 30$
20$: CLRW TMPDSC
30$: BBC #ITM_V_USER,FLAGS,40$ ; Yes, add process name
SUBL3 USR_FIELD_LEN,#<17-1>,R7
BBC #ITM_V_LONG,FLAGS,50$
SUBL3 USR_FIELD_LEN,#,R7
BRB 50$
40$: MOVL #<17-8-1>,R7
BBC #ITM_V_LONG,FLAGS,50$
MOVL #,R7
50$: TSTW TMPDSC
BEQL 60$
CMPL #2,R7
BGEQ 60$
SUBL2 #2,R7
MOVB #^A\(\,(AP)+
CMPW R7,PRCLEN
BLEQ 55$
MOVC3 PRCLEN,PRCNAM,(AP)
ADDL2 PRCLEN,AP
MOVB #^A\)\,(AP)+
SUBL2 PRCLEN,R7
MOVC5 #0,(AP),#BLANK,R7,(AP)
ADDL2 R7,AP
BRB 70$
55$: MOVC3 R7,PRCNAM,(AP)
ADDL2 R7,AP
MOVB #^A\)\,(AP)+
BRB 70$
60$: MOVC5 #0,(AP),#BLANK,R7,(AP)
ADDL2 R7,AP
70$:
ENDRTN PROC
OUTTAB TYPE=UIC,HEAD=<~ UIC >,JPI=UIC,JPIBUF=UIC,- ; /UIC
SWITCH=UIC
OUTRTN UIC
INSERT_BLANK
TSTL UIC
BEQL 10$
MOVL #9,TMPDSC ; Set up for FAO
MOVL AP,
$FAO_S CTRSTR=UIC_CTR,OUTBUF=TMPDSC,P1=UIC+2,P2=UIC
BRB 20$
10$: MOVC3 #9,UIC_NONE,(AP) ; No UIC
20$: ADDL2 #9,AP
ENDRTN UIC
OUTTAB TYPE=TTY,HEAD=<~ TTY >,SWITCH=TERMINAL ; /TERMINAL
OUTRTN TTY
INSERT_BLANK
BBS #ITM_V_HASTTY,FLAGS2,40$
10$: TSTW LGNTRML ; For non-interactive jobs
BEQL 40$
MOVAB LGNTRM,R0 ; It has a login terminal!
20$: CMPB #^A\_\,(R0)
BNEQ 30$
INCL R0
DECW LGNTRML
BEQL 40$
BRB 20$
30$: MOVZWL LGNTRML,R1
DECL R1
CMPB #^A\:\,LGNTRM[R1]
BNEQ 35$
DECW LGNTRML
35$: MOVC5 LGNTRML,(R0),#BLANK,#7,(AP) ; Use it
MOVL R3,AP
BRB 50$
40$: LOCC #^A\:\,#7,TRMBUF ; Move in 6 characters
SUBL2 #TRMBUF,R1
MOVC5 R1,TRMBUF,#BLANK,#7,(AP)
MOVL R3,AP
50$:
ENDRTN TTY
OUTTAB TYPE=TYPE,HEAD=<~ Type >,SWITCH=TYPE ; /TYPE
OUTRTN TYPE
INSERT_BLANK
TSTL OWNER_PID
BEQL 10$ ; Sub-proc?
MOVL #SUBTRM,R6 ; Yes, set type to SUB-PROC
BRB 40$
10$: BBC #ITM_V_BAT1,FLAGS2,20$ ; No, Batch job?
MOVL #BATTRM,R6 ; Yes, set type to BATCH
BRB 40$
20$: BBS #ITM_V_HASTTY,FLAGS2,30$ ; No, non-interactive?
MOVC5 #0,(AP),#BLANK,#7,(AP) ; Yes, blank field
BRB 50$
30$: MOVL TYPE_ARG,R6 ; No, use terminal type
BLSS 35$ ; set unkn type if invalid
CMPL R6,#TRMTABLEN ; past end of table?
BLSS 40$ ; no, branch, it's ok
35$: MOVL #TT$_UNKNOWN,R6 ; yes, set unknown type
40$: MOVL TRMTAB[R6],R0
MOVZBL (R0)+,R1
MOVC5 R1,(R0),#BLANK,#7,(AP)
50$: ADDL2 #7,AP
ENDRTN TYPE
OUTTAB TYPE=IMAGE,HEAD=<~ Image >,- ; /IMAGE
HEAD_LONG=<~ Image >,-
SWITCH=IMAGE
OUTRTN IMAGE
INSERT_BLANK
MOVL #9,R6
BBC #ITM_V_LONG,FLAGS,5$
MOVL #36,R6
5$:
BBC #ITM_V_ALLOTRM,FLAGS2,10$
TSTW LGNTRML ; Login terminal?
BEQL 10$ ; No then image=(alloc)
MOVC5 #ALLOCL,ALLOC,#BLANK,R6,(AP)
BRB 30$
10$:
; TRIM_FILESPEC doesn't work for hidden device strings, such as those
; of system images ([SYS0.][SYSEXE]) so help out by first looking for
; ".]" or ".>"
MOVZWL #^A/.]/,-(SP) ; object substring buf
MATCHC #2,(SP),IMGLEN,IMGNAM ; look for substring match
BEQL 15$ ; match found? yes, branch
MOVZWL #^A/.>/,(SP) ; no, try another substring
MATCHC #2,(SP),IMGLEN,IMGNAM ; match?
BEQL 15$ ; yes, branch
MOVZWL IMGLEN,R2 ; no, pick up entire string
MOVAB IMGNAM,R3
15$:
TSTL (SP)+ ; clean off substring
; build descr on stack
PUSHL R3 ; addr one beyond last byt match
PUSHL R2 ; num bytes remaining in src str
PUSHL AP ; build descr for output str
PUSHL R6 ; with width count for trim
PUSHAQ (SP) ; addr of output str descr
PUSHAQ 12(SP) ; addr of input str descr
CALLS #2,G^LIB$TRIM_FILESPEC ; trim
MOVAL 16(SP),SP ; clean off descriptors
BLBS R0,30$ ; did trim work?
MOVC5 #0,#0,#BLANK,R6,(AP) ; no, blank fill
BRB 40$
30$:
; Some folks think .EXE looks tacky in short form
BBS #ITM_V_LONG,FLAGS,40$ ; is it long fmt? yes, branch
MOVL #^A/.EXE/,-(SP) ; no, get substring for search
MATCHC #4,(SP),R6,(AP) ; look for it
BNEQ 35$ ; found? no, branch
ADDL #4,R2 ; yes, include .EXE in count
SUBL #4,R3 ; backup to point to . of .EXE
MOVC5 #0,#0,#BLANK,R2,(R3) ; wipe out
35$:
TSTL (SP)+ ; clean of substring
40$:
ADDL2 R6,AP
ENDRTN IMAGE
OUTTAB TYPE=STATE,JPI=STATE,JPIBUF=STATE,- ; /STATE
HEAD=<~State>,SWITCH=STATE
OUTRTN STATE
INSERT_BLANK
ALLOCATED 10$
MOVC5 #0,(AP),#BLANK,#5,(AP) ; No state, or alloc.
BRB 20$
10$: MOVL STATE,R0
MOVL STATE_TAB[R0],R0
MOVZBL (R0)+,R1
MOVC5 R1,(R0),#BLANK,#5,(AP)
20$: ADDL2 #5,AP
ENDRTN STATE
OUTTAB TYPE=PRIO,JPI=PRI,JPIBUF=PRIO,- ; /PRIORITY
JPI2=PRIB,JPIBUF2=BASE_PRIO,HEAD=<~Prio.>,-
SWITCH=PRIORITY
OUTRTN PRIO
INSERT_BLANK
ALLOCATED 10$
MOVC5 #0,(AP),#BLANK,#5,(AP) ; Blank for alloc.
BRB 30$
10$: TSTL BASE_PRIO
BNEQ 20$
MOVC3 #5,PRIO_NO,(AP) ; No info.
BRB 30$
20$: MOVL #5,TMPDSC
MOVL AP,
$FAO_S CTRSTR=PRIO_CTR,OUTBUF=TMPDSC,P1=PRIO,P2=BASE_PRIO
30$: ADDL2 #5,AP
ENDRTN PRIO
OUTTAB TYPE=DIRIO,JPI=DIRIO,JPIBUF=DIR_IO,- ; /DIRECT_IO
HEAD=< Dir IO>,HEAD_LONG=<~ Direct I/O>,-
SWITCH=
OUTRTN DIRIO
BBC #ITM_V_LONG,FLAGS,10$
INSERT_BLANK
10$: ALLOCATED 30$
BBS #ITM_V_LONG,FLAGS,20$ ; Alloc. = blank
MOVC5 #0,(AP),#BLANK,#7,(AP)
BRB 70$
20$: MOVC5 #0,(AP),#BLANK,#11,(AP)
BRB 70$
30$: TSTL DIR_IO
BGTR 50$
BBC #ITM_V_LONG,FLAGS,40$ ; Zero gets no info
MOVB #^A\-\,(AP)
MOVW #^A\O \,8(AP)
MOVB #^A\-\,10(AP)
MOVC3 #7,NO_NUMBER,1(AP)
BRB 70$
40$: MOVC3 #7,NO_NUMBER,(AP)
BRB 70$
50$: MOVL #7,TMPDSC
BBC #ITM_V_LONG,FLAGS,60$
MOVL #11,TMPDSC
60$: MOVL AP,
MOVAL DIR_IO,
CALLG NUMBER_LIST,G^OTS$CVT_L_TI
70$: ADDL2 #7,AP
BBC #ITM_V_LONG,FLAGS,80$
ADDL2 #4,AP
80$:
ENDRTN DIRIO
OUTTAB TYPE=BUFIO,JPI=BUFIO,JPIBUF=BUF_IO,- ; /BUFFERED_IO
HEAD=< Buf IO>,HEAD_LONG=<~Buffered IO>,-
SWITCH=
OUTRTN BUFIO
BBC #ITM_V_LONG,FLAGS,10$
INSERT_BLANK
10$: ALLOCATED 30$
BBS #ITM_V_LONG,FLAGS,20$ ; Alloc. = blank
MOVC5 #0,(AP),#BLANK,#7,(AP)
BRW 70$
20$: MOVC5 #0,(AP),#BLANK,#11,(AP)
BRB 70$
30$: TSTL BUF_IO
BGTR 50$
BBC #ITM_V_LONG,FLAGS,40$ ; Zero gets no info
MOVB #^A\-\,(AP)
MOVW #^A\O \,8(AP)
MOVB #^A\-\,10(AP)
MOVC3 #7,NO_NUMBER,1(AP)
BRB 70$
40$: MOVC3 #7,NO_NUMBER,(AP)
BRB 70$
50$: MOVL #7,TMPDSC
BBC #ITM_V_LONG,FLAGS,60$
MOVL #11,TMPDSC
60$: MOVL AP,
MOVAL BUF_IO,
CALLG NUMBER_LIST,G^OTS$CVT_L_TI
70$: ADDL2 #7,AP
BBC #ITM_V_LONG,FLAGS,80$
ADDL2 #4,AP
80$:
ENDRTN BUFIO
OUTTAB TYPE=PAGEFLTS,JPI=PAGEFLTS,JPIBUF=PAGE_FLTS,- ; /PAGE_FAULTS
HEAD=< Pg flt>,HEAD_LONG=<~Page faults>,-
SWITCH=
OUTRTN PAGEFLTS
BBC #ITM_V_LONG,FLAGS,10$
INSERT_BLANK
10$: ALLOCATED 30$
BBS #ITM_V_LONG,FLAGS,20$ ; Alloc. = blank
MOVC5 #0,(AP),#BLANK,#7,(AP)
BRW 70$
20$: MOVC5 #0,(AP),#BLANK,#11,(AP)
BRB 70$
30$: TSTL PAGE_FLTS
BGTR 50$
BBC #ITM_V_LONG,FLAGS,40$ ; Zero gets no info
MOVB #^A\-\,(AP)
MOVW #^A\O \,8(AP)
MOVB #^A\-\,10(AP)
MOVC3 #7,NO_NUMBER,1(AP)
BRB 70$
40$: MOVC3 #7,NO_NUMBER,(AP)
BRB 70$
50$: MOVL #7,TMPDSC
BBC #ITM_V_LONG,FLAGS,60$
MOVL #11,TMPDSC
60$: MOVL AP,
MOVAL PAGE_FLTS,
CALLG NUMBER_LIST,G^OTS$CVT_L_TI
70$: ADDL2 #7,AP
BBC #ITM_V_LONG,FLAGS,80$
ADDL2 #4,AP
80$:
ENDRTN PAGEFLTS
OUTTAB TYPE=WSET,JPI=WSSIZE,JPIBUF=WORK_SET,- ; /WORKING_SET
HEAD=<~Wset>,SWITCH=
OUTRTN WSET
INSERT_BLANK
ALLOCATED 10$
MOVC5 #0,(AP),#BLANK,#4,(AP) ; Alloc.
BRB 30$
10$: TSTL WORK_SET
BNEQ 20$
MOVC3 #4,WSET_NO,(AP) ; No info.
BRB 30$
20$: MOVL #4,TMPDSC
MOVL AP,
CALLG WSET_LIST,G^OTS$CVT_L_TI
30$: ADDL2 #4,AP
ENDRTN WSET
OUTTAB TYPE=PHMEM,JPI=PPGCNT,JPIBUF=PHYS_MEM,- ; /PHYSICAL_MEMORY
HEAD=<~ Mem>,SWITCH=
OUTRTN PHMEM
INSERT_BLANK
ALLOCATED 10$
MOVC5 #0,(AP),#BLANK,#4,(AP) ; Alloc.
BRB 30$
10$: TSTL PHYS_MEM
BNEQ 20$
MOVC3 #4,PHMEM_NO,(AP) ; No info.
BRB 30$
20$: MOVL #4,TMPDSC
MOVL AP,
CALLG PHMEM_LIST,G^OTS$CVT_L_TI
30$: ADDL2 #4,AP
ENDRTN PHMEM
OUTTAB TYPE=CPU,JPI=CPUTIM,JPIBUF=CPUTIM,- ; /CPU_TIME
HEAD=< CPU >,HEAD_LONG=<~ CPU >,-
SWITCH=
OUTRTN CPU
BBC #ITM_V_LONG,FLAGS,5$
INSERT_BLANK
5$: ALLOCATED 10$
MOVC5 #0,TIMESTR,#BLANK,#11,TIMESTR
BRW 50$
10$: TSTL CPUTIM
BNEQ 30$ ; If zero, say -NO INFO-
MOVAB CPUSTR,R0
BBC #ITM_V_LONG,FLAGS,20$
MOVW #^A\ -\,CPUSTR
MOVB #^A\-\,
ADDL2 #2,R0
20$: MOVC3 #8,NOCPU,(R0)
BRW 50$
30$: ADDL2 #5,CPUTIM ; Otherwise...
DIVL3 #6000,CPUTIM,R3 ; Get minutes
MULL3 #6000,R3,R5
SUBL2 R5,CPUTIM
DIVL3 #100,CPUTIM,R4 ; Get seconds
MULL3 #100,R4,R5
SUBL2 R5,CPUTIM
DIVL2 #10,CPUTIM ; Get tenths of seconds
BBS #ITM_V_LONG,FLAGS,40$ ; format string
MOVQ R3,TIME_PLIST
MOVL CPUTIM,
$FAOL_G SHORT_CPU_FAO
BRB 50$
40$: DIVL3 #60,R3,TIME_PLIST ; Get hours
MULL3 #60,TIME_PLIST,R2
SUBL2 R2,R3
MOVQ R3,
MOVL CPUTIM,
$FAOL_G LONG_CPU_FAO
50$: MOVC3 CPUDSC,CPUSTR,(AP)
ADDL2 CPUDSC,AP
ENDRTN CPU
OUTTAB TYPE=ELAPSED,JPI=LOGINTIM,JPIBUF=LOGIN_TIME,- ; /ELAPSED_TIME
JPISIZ=8,HEAD=< Time >,HEAD_LONG=<~ Elapsed >,-
SWITCH=
OUTRTN ELAPSED
BBC #ITM_V_LONG,FLAGS,5$
INSERT_BLANK
5$: ALLOCATED 10$
MOVC5 #0,TIMESTR,#BLANK,#11,TIMESTR
10$: TSTL LOGIN_TIME
BNEQ 30$ ; If zero, say -NO INFO-
MOVAB TIMESTR,R0
BBC #ITM_V_LONG,FLAGS,20$
MOVW #^A\ -\,TIMESTR
MOVW #^A\- \,
ADDL2 #2,R0
20$: MOVC3 #7,,(R0)
BRW 50$
30$: $GETTIM_S TIMADR=CUR_TIME ; Otherwise...
SUBL2 LOGIN_TIME,CUR_TIME ; Get delta
SBWC ,
EDIV #100000,CUR_TIME,R3,R4
ADDL2 #5,R3
DIVL3 #6000,R3,R4 ; Get minutes
MULL3 #6000,R4,R5
SUBL2 R5,R3
DIVL3 #100,R3,R5 ; Get seconds
BBS #ITM_V_LONG,FLAGS,40$ ; format string
MOVQ R4,TIME_PLIST
$FAOL_G SHORT_ELAP_FAO
BRB 50$
40$: MULL3 #100,R5,R6
SUBL2 R6,R3
DIVL3 #10,R3, ; Get tenths of seconds
DIVL3 #60,R4,TIME_PLIST ; Get hours
MULL3 #60,TIME_PLIST,R0
SUBL2 R0,R4
MOVQ R4,
$FAOL_G LONG_ELAP_FAO
50$: MOVC3 TIMEDSC,TIMESTR,(AP)
ADDL2 TIMEDSC,AP
ENDRTN ELAPSED
OUTTAB TYPE=LOC,HEAD=<~ Location>,- ; /LOCATION
HEAD_LONG=<~ Location>,SWITCH=LOCATION
OUTRTN LOC
INSERT_BLANK
; This assumes that this is the LAST field in the list.
;
; Note that the below algorithm is fastest when the terminals found
; (currently opa0 followed by all other terminals in alphanumeric order)
; are in the same order as they are in the ports file. Note that the
; algorithm is SLOWEST when they are in reverse order, and, if a terminal
; does not exist in the ports file, the program will go through that file
; TWICE (at worst case) to discover that fact.
; the terminal name to key on is expected to be the first 5 characters
; (including ":") of the line in the file record
BBC #ITM_V_BAT1,FLAGS2,20$
BBS #ITM_V_LONG,FLAGS,10$ ; Batch job
MOVC5 LOCLEN,@,#BLANK,#30,(AP)
ADDL2 #30,AP
BRW 110$
10$: MOVC3 LOCLEN,@,(AP)
ADDL2 LOCLEN,AP
BRW 110$
20$: BBS #ITM_V_HASTTY,FLAGS2,50$
TSTW LGNTRML ; See if there is a login
BNEQ 22$
BRW 110$
22$:
MOVZWL LGNTRML,TRMLEN
MOVAB LGNTRM,R0
30$: CMPB #^A\_\,(R0) ; Get rid of leading _'s
BNEQ 40$
DECL TRMLEN
INCL R0
BRB 30$
40$:
MOVC3 TRMLEN,(R0),TRMBUF
50$:
CMPW #RT_TYPE,TRMBUF ; Remote terminal
BNEQ 70$
MOVC3 #RT_LOC_LEN,RT_LOC,(AP)
ADDL2 #RT_LOC_LEN,AP
60$: BRW 110$
70$: CMPW #VT_TYPE,TRMBUF
BNEQ 77$
; get physical name of virtual terminal
PUSHL #0 ; end of list
PUSHAW TRMLEN ; addr for returned length
PUSHAB TRMBUF ; addr of buf
PUSHL #DVI$_TT_PHYDEVNAM @16- ; code and buf len
! TERM_BUF_LEN
MOVL SP,R0 ; get addr of list
$GETDVIW_S - ; get phys term name
DEVNAM=TRMLEN,-
ITMLST=(R0)
MOVAL 16(SP),SP ; clean off itmlst
BLBS R0,76$ ; got a phys term name?
BRW 110$
76$: CMPB #^A/_/,TRMBUF ; name start with underscore?
BNEQ 77$ ; no, got it right
DECW TRMLEN ; reduce descr count by 1
MOVC3 TRMLEN,TRMBUF+1,TRMBUF ; shift string left by 1
77$:
CLRL PORTPASS
80$: $GET RAB=PORTRAB ; Get a record
BLBS R0,90$ ; If an error occurs in read
TSTL PORTPASS ; Through file already?
BEQL 85$
BBC #ITM_V_ALLOTRM,FLAGS2,83$
BRW 115$ ; Yes, then done
83$: BRW 120$
85$: $REWIND RAB=PORTRAB ; No, try another pass
INCL PORTPASS
BRB 80$
90$: ; Take into account comments
LOCC #PORT_COMMENT,,LOCBUF
SUBW2 R0,
CMPW #5,
BGTR 80$ ; No terminal here, loop
CMPC5 TRMLEN,TRMBUF,#0,#5,LOCBUF
BNEQ 80$ ; Not the same, loop
LOCC #BLANK,PORTRAB+RAB$W_RSZ,LOCBUF
SKPC #BLANK,R0,(R1) ; Get location descriptor
BBS #ITM_V_LONG,FLAGS,100$
MOVC5 R0,(R1),#BLANK,#30,(AP) ; Short output
ADDL2 #30,AP
BRB 110$
100$: MOVL R0,R6
MOVC3 R0,(R1),(AP)
ADDL2 R6,AP
110$: BBC #ITM_V_ALLOTRM,FLAGS2,120$
MOVAB RECBUF, ; Say (alloc) if necessary
SUBL3 #RECBUF,AP,TMPDSC
CALLG TRIM_LIST,G^STR$TRIM
ADDL3 TMPDSC,,AP
115$: MOVB #BLANK,(AP)+
MOVC3 #ALLOCL,ALLOC,(AP)
ADDL2 #ALLOCL,AP
120$:
ENDRTN LOC
OUTTAB ALLO,SWITCH= ; /ALLOCATED_DEVICES
OUTTAB ALL,SWITCH= ; /ALL_PROCESSES
OUTTAB DCL,SWITCH= ; /DCL
OUTTAB LONG,SWITCH=LONG ; /LONG
MULTI_SWITCH FLAGS=ALL_OUT_FIELDS,SWITCH=
OUTTAB EXACT,SWITCH=EXACT ; /EXACT
OUTTAB MATCH.OR,SWITCH=MATCH.OR ; /MATCH=OR
OUTTAB MATCH.AND,SWITCH=MATCH.AND ; /MATCH=AND
OUTTAB MATCH.NOR,SWITCH=MATCH.NOR ; /MATCH=NOR
OUTTAB MATCH.NAND,SWITCH=MATCH.NAND ; /MATCH=NAND
FLAGDEF BAT1 ; Indicates cur. PID is batch
FLAGDEF SUB1 ; Indicates cur. PID is sub.
FLAGDEF SUB2 ; Indicates we are processing subs.
FLAGDEF ALL1 ; Indicates current PID is non-INT. job
FLAGDEF HASTTY ; Indicates this is from GETTTY
FLAGDEF ALLOTRM ; Indicates terminal is not LOGIN one
FLAGDEF FIRST ; Indicates this is first output field
FLAGDEF SRCH ; Search string present
.END WHERE