C..Finger.For				Callable finger routine
C..					R. Garland / C.U.Chemistry

	Integer Function Finger(Command_line,Finger_Out_Routine)

C	Function-
C		o To provide detailed information about users on system.
C		o To provide additional information about an individual.
C		o To request out-bound, or to answer in-bound network
C		  requests to/from other hosts supporting finger.
C
C	Author-
C		Dr. Richard Garland
C		Department of Chemistry
C		Box 351 Havemeyer Hall
C		Columbia University
C		New York, NY, 10027
C		(212) 280-3183
C
C	Disclaimer/rights-
C		This software is in the public domain and is
C		provided free though DECUS or other channels.
C
C	Environment-
C		VAX/VMS V4.x
C		Must be installed with CMKRNL,SYSPRV, and WORLD privileges.
C			CMKRNL - to get the idle times from the UCB's.
C			SYSPRV - so it can read SYSUAF.DAT
C			WORLD - so it can do GETJPI's on processes.
C
C	Routines required, installation:
c		read FINGER.DOC and use the procedure INSTALL_FINGER.COM
c		and BUILD_FINGER.COM

C
C	Edition/changes-
C
c	Note:	Early update history is at the end of this source.
c
c	V5.63	Adapt for uVAX. (VMS V4.0 changes)		5-Nov-1984
c			CPU type: add uVAX I
c			Imagename: multiple brakets [ ][ ] etc.
c			Default Dir from SYSUAF
c			PID format
c	V5.64	real V4.0 came					12-Jan-1985
c			Get DCL parse kludge from BJJ @ PSUVMS1
c			GET_ID from CRW @PSUVMS1 (Mail stuff)
c			New IDLE.MAR (BJJ @ PSUVMS1) to use EPIDs
c
c	New version format: Vx.y.z - 	x = VMS version
c					y = major finger version
c					z = finger revision
c	V5.64 => V40.0.7					12-Jan-1984
c	V40.0.8	-	new V4.0 QUENAME (PJO @ PSUVMS1)	14-Jan-1985
c	V40.0.9	-	disable DECNET node name for now	14-Jan-1985
c	V40.0.10 -	Use LIB$DAY_OF_WEEK			17-Jan-1985
c	V40.0.11 -	Put in new CPU types			17-Jan-1985
c	V40.0.12 -	Put in last login time			17-Jan-1985
c	V40.0.13 -	Integrate Mark London (MIT) changes 
c			into IDLE.MAR				24-Jan-1985
c	V40.0.13	Add filter for printing control chars.	29-Jan-1985
c	V40.0.14	Rewrite and rename Idle --> TT_UCB.  Now it
c			also gets physcial terminal name.	31-Jan-1985
c	V40.0.15	Transform VT's into TT's in Get_Location 31-Jan-1985
c	V40.0.16	Allow local host name to be set other than
c			DECnet node name			6-Feb-1985
c	V40.0.17	Add "Organization name" to heading	7-Feb-1985
c	V40.0.18	Include Peter Lucas's TCP code untested	12-Feb-1985
c	V40.0.19	Search multiple nets for a node (ala PAL) 12-Feb-1985
c	V40.0.20	Default "router" stuff (ala PAL)	15-Feb-1985
c	This was sent out to some sites as a "beta test"	15-Feb-1985
c	----------------
c	V40.0.21	minor fixes to above			19-Feb-1985
c	V40.0.22	more of same				20-Feb-1985
c	V40.0.23	enable privs only when needed		25-Feb-1985
c	V40.0.24	require EXEC mode log name translation	27-Feb-1985
c	V40.0.25	jnet_Finger using global sec after getting
c			status that there wasn't one.		28-Feb-1985
c	V40.0.26	Fix TTUCB and Finger for RT DECnet nodes 8-Mar-1985
c	V40.0.26	Take EXEC mode out for FINGER$MESSAGE	25-Mar-1985
c	V40.0.27	Change Open of SYSUAF for VMS 4.1	25-Mar-1985
c	V40.0.28	make singular "user" in header		25-Mar-1985
c	V40.1.00	Call this VMS 4.0 "release version"	25-Mar-1985
c	----------------
c	V40.1.01	Put "%Val( )" in SYS$DASSGN: Get_DECnet_Node
c			turn off CMKRNL: Get_Idle_Times		3-Apr-1985
c	V40.1.02	Trim trailing space off ORGANIZATION	5-Apr-1985
c	V40.1.03	Make 7 chars default for Terminal names
c			to accomodate VTA's			16-Apr-1985
c	V40.1.04	Assign channel each time: Get_DEC_Node	17-Apr-1985
c	V40.1.05	fix for jnet V2X2 add SYS$CANEXH	21-Apr-1985
c	V40.1.06	Fix by Mike Cochran <Mike@Mecan1.BITnet>
c			for last users in UAF problem		22-Apr-1985
c	V41.1.07	Close with privilege files so opened	20-May-1985
c	V41.1.08	Move open of UAF inline. kill OPEN_UNITS 20-May-1985
c	V41.1.09	Change $TRNLOG to $TRNLNM 		20-May-1985
c	V41.1.10	Look for "::" if no "@" in command.	21-May-1985
c			above 3 changes from Dan Cottler of RCA
c	V41.1.11	Don't cut "_" in Node if there isn't one 5-Jul-1985
c	V41.1.12	List "From: so-and-so" mail messages	19-Jul-1985
c	V41.1.13	Incorporate GET_ID into PERSONAL_INFO,
c			get correct mail subdirectory		21-Jul-1985
c	V41.1.14	Fix PERSONAL_INFO to deal with mail
c			subdirectories				23-Jul-1985
c	V41.1.15	Fix bug in GET_LOCATION for VTA's	23-Jul-1985
c	V41.1.16	Compile time option for latest message
c			only - Personal_info			3-Aug-1985
c	V41.1.17	Use new JANLIB routines in jnet_FINGER	5-Sep-1985
c	V41.1.18	Merge in R. Greenberg's sort routines	22-Sep-1987
c			and other RCA and GE changes.
c	V45.1.01	Add in code to check UIC of individual 
c			fingered against owner UIC of FINGER.PLN
c			to thwart spoofs vis SET FILE/ENTER	28-Sep-1987
c	V46.1.01	Eliminate dual definitions of system
c			services in function Priv_UserOpen. By
c			Rand P. Hall <rand@merrimack.edu>	22-Oct-1987
c	V46.1.02	Changed all references to terminals to
c			Character*8 instead of *7 (ie, can now
c			handle VTA1234:). By Rand P. Hall	06-Jan-1988
c	V46.1.03	Made LAT terminal identification code
c			functional. Added a couple more cpus.
c			By Rand P. Hall				06-Jan-1988
c	V46.1.04	Made display of unread mail more realistic.
c			You now have the option of displaying only
c			mail from you. Fixed a few .02 bugs. Tested
c			with the LTDRIVER from the VMS 4.7 kit.
c			By Rand P. Hall				29-Jan-1988
c	V47.1.00	Works w/ 4.7. Fingering someone NOT in the 
c			Finger Common Block works, again. Mail file
c			processing now has two options: A) Display
c			only # of new mail messages, or B) Display
c			A plus DATE and SUBJECT of unread messages
c			sent to the Fingeree from the Fingerer.
c			Sort routine loads indices more efficiently.
c			All cpu types now handled. By Rand Hall 04-Apr-1988
c	V50.1.00	Works with 5.0-1 with one exception-no one has
c			gotten TT_UCB to work, hence I NoOp'd it. For me this
c			is minor. Included is new load average driver support.
c			Both the Mail.mai and Vmsmail.dat sections were
c			rewritten to support v5 formats. LAT port and Queue
c			name code now uses documented interfaces.
c			By Rand P. Hall				11-Oct-1988
c
C	This routine can be called locally or via a network object.
c	In any case, the output is processed by an external routine
c	specified as an argument.  This makes it somewhat independent
c	of invocation.

	Include		'Fingercom'
	Include		'Fingerdef.inc'

	Character VersionMsg*51
	1	/'VAX/VMS Finger: Version V50.1.00 of 11-Oct-1988'/
	Common	/Version_Common/ VersionMsg

	Integer		Privilege(2) /0,0/
	Integer		Btrim
	Logical		Wild, Wild_Match
	Character	Command_line*(*)
	Character	Expanded_Command*132
	Character	Node*12, Next_Node*12
	Character	Get_Node*12, Save_Node*12
	Character	Route*72, Node_Type*1
	Character	CR /13/,	LF /10/,	SP /' '/
	Character	Slash /'/'/,	Flush/255/

	Integer		
	1		OutboundLinkUnit /11/,
	2		UafUnit /12/,
	3		ScratchUnit /13/

	Common	/IO_Units/ 
	1		OutboundLinkUnit,
	2		UafUnit,
	3		ScratchUnit

	External	Finger_Out_Routine
	External	Fing_NoWild
	External	Fing_NoNode
	External	Fing_NoNet

	Integer		Local_Finger,
	1		Remote_Finger


c  Turn off privileges
	Privilege(1) = Prv$M_Cmkrnl .or. Prv$M_World .or. Prv$M_Sysprv
	Call Sys$Setprv(,Privilege,,)

c  start processing command
	l_com = Len(Command_line)

C  Strip CR//LF off Command_line
	i_CRLF = Index(Command_line,CR//LF)
	If ( i_CRLF .ne. 0 ) l_Com = i_CRLF - 1

C  Find node name: look for @-sign
10	Do ii=l_Com,1,-1
	    If ( Command_line(ii:ii) .eq. '@' ) Then
		i_At = ii
		GoTo 110
	    EndIf
	EndDo
c  check also for "::" if there are no @-signs
	i_cc = index(command_line,'::')
	If (i_cc.ne.0) then
	    do ii = i_cc,1,-1
	       if (command_line(ii:ii).eq.slash) goto 20
	       if (command_line(ii:ii).eq.sp   ) goto 20
	    end do
	    ii = 0
20	    node = command_line(ii+1:i_cc-1)
	    l_node = i_cc - ii - 1
	    Command_line(ii+1:i_cc+1) = '@'//node(:l_node)//' '
	    Go to 10
	End if
	
	Finger = Local_Finger(Command_line(:l_Com),Finger_Out_Routine) ! No node name:
								! local finger
	Return

110	Continue
	Node = Command_line(i_At+1:l_Com)		! This is the node name
	l_Node = l_Com - i_At
	Do ii = 2,l_Node
	    If ( Node(ii:ii) .eq. Slash ) GoTo 111
	    If ( Node(ii:ii) .eq. SP ) GoTo 111
	EndDo
	GoTo 112
111	l_Node = ii - 1
112	Continue
	Save_Node = Node
	l_Save_node = l_node

c  see if there are wildcards in node name
	ii_node = 1
	wild = .false.
	If ( (Index(Node(:l_Node),'*')+Index(Node(:l_Node),'%'))
	1	.gt. 0 ) then
		wild = .true.
		ii_node = Host$I_Last
		Finger = %Loc(Fing_NoWild)
	End if
c  loop though node names, or do just one.
	Do ii = 1,ii_node
	    If ( wild ) then
		l_host = Btrim(Host$C_Host(ii))
		if ( Wild_Match(Save_Node(:l_Save_Node),
	1	Host$C_Host(ii)(:l_host)) ) then
		    Node = Host$C_Host(ii)
		    l_node = l_host
		Else
		    Go to 200	
		End if
	    End if
c  Get routing information
	    Next_Node = Get_Node(Node(:l_Node),Node_Type,Route,.false.)
C  Format  command 
	    Expanded_Command = Command_line(:i_AT-1)//
	1	Route(:Btrim(Route))//
	2	Command_line(i_AT+l_Save_Node+1:l_Com)

C  send command out to appropriate network/node

	    Finger = Remote_Finger(Next_Node(:Btrim(Next_Node)), 
	1	Expanded_Command(:Btrim(Expanded_Command)),
	2	Finger_Out_Routine, Node_Type)

c  If a wild card net and node not found, see if there is a default router
	    If ( Node_Type.eq.'*' .and. Finger.eq.%Loc(Fing_NoNode) ) then
c	Get routing information for Router
		Next_Node = Get_Node(Node(:l_Node),
	1	    Node_Type,Route,.true.)
		If ( Next_Node .eq. ' ' ) then		! no router: give up.
		    Call Finger_Out_Routine(': link failed]'//CR//LF)
		    Call Lib$Signal(Fing_NoNode)
		    Return
		End if
C	Format  command 
		Expanded_Command = Command_line(:i_AT-1)//
	1	    Route(:Btrim(Route))//
	2	    Command_line(i_AT+l_Save_Node+1:l_Com)

c	notify user we are rerouting
		Call Finger_Out_Routine(': rerouting link via '//
	1	    Next_Node(:Btrim(Next_Node))//']'//CR//LF)

C	send command out to appropriate network/node

		Finger = Remote_Finger(Next_Node(:Btrim(Next_Node)), 
	1	    Expanded_Command(:Btrim(Expanded_Command)),
	2	    Finger_Out_Routine, Node_Type)

	    End if
200	    Continue
	End do

C Done
	Return

	End

c------------------------------------------------------------------------
	Integer Function Remote_Finger(Next_Node, Command,
	1			Finger_Out_Routine, Node_Type)


	Character	Command*(*)
	Character	Next_Node*(*)
	Character	Node_Type*1
	Character	Flush/255/

	External	Finger_Out_Routine
	External	Fing_Nonode, Fing_NoNet

	Integer		Local_Finger,
	1		DECnet_Finger,
	3		jnet_Finger,
	4		TCP_Finger

	Logical		WildNet, NoNode

	NoNode = .false.
	If ( Node_Type .eq. '*' ) then
	    WildNet = .true.
	Else
	    WildNet = .false.
	End if

c  see if it's really local
	If ( Node_Type .eq. 'L' ) Then				! Local
	    Remote_Finger = Local_Finger(Command,Finger_Out_Routine)
	    Return
	End if

c  Notify requester trying to open link
	Call Finger_Out_Routine('['//Next_Node//Flush)

c  dispatch by network type

	If ( WildNet .or. (Node_Type.eq.'D') ) then	! DECnet
	    Remote_Finger = DECnet_Finger(Next_Node,Command,
	1   Finger_Out_Routine)
	    If ( WildNet .and. (Remote_Finger.eq.%Loc(Fing_NoNode)) )
	1	NoNode = .true.
	    If ( .not. WildNet ) Return 
	    If ( .not.(	Remote_Finger.eq.%Loc(Fing_NoNode) .or.
	1		Remote_Finger.eq.%Loc(Fing_NoNet) ) ) Return
	End if

	If ( WildNet .or. 
	1	(Node_Type.eq.'J') .or. (Node_Type.eq.'I') ) then ! jnet
	    Remote_Finger = jnet_Finger(Next_Node,Command,
	1   Finger_Out_Routine,Node_Type)
	    If ( WildNet .and. (Remote_Finger.eq.%Loc(Fing_NoNode)) )
	1	NoNode = .true.
	    If ( .not. WildNet ) Return 
	    If ( .not.(	Remote_Finger.eq.%Loc(Fing_NoNode) .or.
	1		Remote_Finger.eq.%Loc(Fing_NoNet) ) ) Return
	End if

	If ( WildNet .or. (Node_Type.eq.'T') ) then	! TCP
	    Remote_Finger = TCP_Finger(Next_Node,Command,
	1   Finger_Out_Routine)
	    If ( WildNet .and. (Remote_Finger.eq.%Loc(Fing_NoNode)) )
	1	NoNode = .true.
	    If ( .not. WildNet ) Return 
	    If ( .not.(	Remote_Finger.eq.%Loc(Fing_NoNode) .or.
	1		Remote_Finger.eq.%Loc(Fing_NoNet) ) ) Return
	End if
	
	If ( WildNet .and. NoNode ) then
	    Remote_Finger = %Loc(Fing_NoNode)
	Else
	    Remote_Finger = %Loc(Fing_NoNet)
	End if

	Return
	End

c------------------------------------------------------------------------
	Character*12 Function Get_Node(Node,Node_Type,Route,Router)

	Include		'FingerCom.For'

	Character	Node*(*), Node_Type*1, Route*72
	Logical		Router


c  see if we want the default router node
	If ( Router ) then
	    Get_Node = Net$C_Router_Host
	    If ( Get_Node .eq. ' ' ) Return
	    Route = '@'//Node//Net$C_Router_Route
	    Node_Type = Net$C_Router_Type
	    Return
	End if

c  otherwise do a regular look up
	Do ii = 1,Host$I_Last
	    If ( Node .eq. Host$C_Host(ii) ) then
		Get_Node = Host$C_Link(ii)
		If ( Get_Node .eq. ' ' ) Get_Node = Node
		Node_Type = Host$C_Type(ii)
		Route = Host$C_Route(ii)
		Return
	    End if
	End do

c  not found: default to Wild card
	Get_Node = Node
	Node_Type = '*'
	Route = ' '
	Return

	End

c------------------------------------------------------------------------
	Character*20 Function Get_Network(Net_Type)

	Include		'FingerCom.For'

c  look up name of network in database.

	Character	Net_Type*1
	Integer		length

c  in case we don't find it, some defaults
c  [rph-25-mar-88] this used to be 4 straight IFs

	Get_Network = 'Net'

	If ( Net_Type .eq. 'D' ) then
	  Get_Network = 'DECnet'
	else If ( Net_Type .eq. 'J' ) then
	  Get_Network = 'jnet'
	else If ( Net_Type .eq. 'I' ) then
	  Get_Network = 'jnet'
	else If ( Net_Type .eq. 'T' ) then
	  Get_Network = 'TCP'
	endif

	Do ii = 1,Net$I_Last
	    If ( Net_Type .eq. Net$C_Type(ii) ) then
		Get_Network = Net$C_Name(ii)
	    End if
	End do

	Return
	End

c------------------------------------------------------------------------
	Integer Function DECnet_Finger(Next_Node,Net_Command,
	1			Finger_Out_Routine)

c  Do a Finger of a remote DECnet node.  Establish the link, send
c  the command, and relay the output back to the requestor.

	Include		'($SSDEF)'
	Include		'($RMSDEF)'

c ** Site-Specific ** needed for BYPASS logic
c	COMMON /BCZCOM/ FLAG_BYPASS
c	LOGICAL FLAG_BYPASS

	Character	Next_Node*(*), Net_Command*(*)

	Integer		Btrim
	Character	Line*32000,	NUL/0/
	Character	CR /13/,	LF /10/,	SP /' '/
	Character	Flush /255/
	Character	OpenMsg*80
	Character	Network*20,	Get_Network*20

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

	Common	/IO_Units/ 
	1		OutboundLinkUnit,
	2		UafUnit,
	3		ScratchUnit

	Integer		OutLinkOpenStatus, OutLinkRMSStatus
	Common		/OutLinkOpen_Common/ OutLinkOpenStatus,
	1			OutLinkRMSStatus

	External	Finger_Out_Routine
	External	Fing_Complete,	Fing_Abort
	External	Fing_NoNode, Fing_NoNet
	External	OutLink_UserOpen

c  Default return status
	DECnet_Finger = %Loc(Fing_Complete)
c  Establish DECnet link
	Open(	Unit=OutboundLinkUnit,
	1	File=Next_Node//'::"117="',
	2	Type='UNKNOWN',
	3	CarriageControl='NONE',
	4	Err=145,
	5	UserOpen=OutLink_UserOpen,
	6	Recl=32000,
	7	BlockSize=32000)
c  Get network name
	Network = Get_Network('D')
c  Finish message
	Call Finger_Out_Routine('.'//Network(:Btrim(Network))//']'//CR//LF)
	GoTo 150

c  Error establishing link
145	Continue
	If ( OutLinkOpenStatus .eq. SS$_NOSUCHNODE ) then
	    DECnet_Finger = %Loc(Fing_NoNode)
	    Return
	End if
	If ( OutLinkRMSStatus .eq. RMS$_NOD ) then	! Bad node name for
	    DECnet_Finger = %Loc(Fing_NoNode)		! DECnet may be OK
	    Return					! on another net.
	End if
	If ( OutLinkOpenStatus .eq. SS$_DEVNOTMOUNT ) then
	    DECnet_Finger = %Loc(Fing_NoNet)
	    Return
	End if
	Call Finger_Out_Routine(': link failed]'//CR//LF)
	Call Lib$Signal(%Val(OutLinkOpenStatus.or.2**27)) !turn on customer bit
	DECnet_Finger = %Loc(Fing_Abort)
	Return

c  Send command over link
150	Continue
c
c ** Site-Specific ** uncomment next for bypass switch stuff
c	IBCZ=INDEX(NET_COMMAND,'/BY')
c	IF(IBCZ.NE.0)THEN
c	 IIBCZ=LEN(NET_COMMAND)
c	 IBCZEND=INDEX(NET_COMMAND(IBCZ+1:IIBCZ),'/')
c	 IF(IBCZEND.EQ.0)IBCZEND=INDEX(NET_COMMAND(IBCZ+1:IIBCZ),' ')
c	 IF(IBCZEND.EQ.0) THEN
c	   IBCZEND=IIBCZ+1
c	 ELSE
c	   IBCZEND=IBCZEND+IBCZ
c	 ENDIF
c	  DO IBCZTMP=IBCZ,IBCZEND-1
c	   NET_COMMAND(IBCZTMP:IBCZTMP)=' '
c	  END DO
c	 FLAG_BYPASS = .TRUE.
c	ENDIF
c
	Write(OutboundLinkUnit,1002)
	1	Net_Command//CR//LF

C  Read response from network
	DoWhile(.true.)
C ** Site-Specific
C uncomment next for bypass logic
c	      IF (.NOT.FLAG_BYPASS) THEN
c		do ibcz=1,il
c		  if(line(ibcz:ibcz).lt.' ')then
c		     iibcz=ichar(line(ibcz:ibcz))
c		     if(iibcz.ne.9.and.iibcz.ne.10
c	1	        .and.iibcz.ne.13)line(ibcz:ibcz)='.'
c		  endif
c		enddo
c	      ENDIF
	    Read(OutboundLinkUnit,1001,End=200) il,Line
	    nl = il/80
	    Do ii = 1,nl
		Call Finger_Out_Routine(Line((ii-1)*80+1:ii*80))
	    EndDo
	    Call Finger_Out_Routine(Line(nl*80+1:il))
	EndDo
200	Continue

c  Make sure link is closed
	Close( Unit=OutboundLinkUnit, Err=201)
201	Continue

	Return

1001	Format(Q,A)
1002	Format(A)

	End

c------------------------------------------------------------------------
	Integer Function jnet_Finger(Next_Node,Net_Command,
	1			Finger_Out_Routine,Node_Type)

c  Do a Finger of a remote jnet node.  Establish the link, send
c  the command, and relay the output back to the requestor.

c  The routine calls to the jnet network are based on interfaces
c  to jnet (tm), a software product available from Joiner Associates
c  of Madison Wisconsin.  This software allows a VAX/VMS system to
c  emulate a full VM (IBM) RSCS node.  jnet is a trademark of
c  Joiner Associates.  BITnet is a network of Universities pri-
c  marily using IBM systems and RSCS protocols.

c  use new jnet interface		31-Aug-1985	Rg

	Character	Next_Node*(*), Net_Command*(*), Node_Type*1
	External	Finger_Out_Routine

	Include		'FingerDef.inc'

	Integer		Btrim
	Integer		IDaemon /.false./
	Common		/jnet_Daemon/ IDaemon
	Logical		TimedOut
	Common		/jnet_Common/ TimedOut
	Integer		Status, Mode
        Character	Line*99, Line2*99
	Character	Str$Upcase*99
        Character       Node*8, User*8
	Character	InitialTimeout*13 /'0 00:00:30.00'/
	Character	Timeout*13 /'0 00:00:10.00'/
	Integer		InitialTime(2)
	Integer		DeltaTime(2)
	Character	CR /13/, LF /10/, Flush/255/
	Logical		started
	Character	Network*20,	Get_Network*20

	External	Fing_Complete,	Fing_Abort,  Fing_Multj
	External	Rou_NoNode
	External	Fing_jNA, Fing_NoNode, Fing_NoNet
	External	jnet_Timer_AST
	Integer		Privilege(2) /0,0/
     
c  Set default return status
	jnet_Finger = %Loc(Fing_Complete)
c  check for (reentrant) call from DAE
	If ( IDaemon ) then
	    If ( Node_Type .eq. '*' ) then
		jnet_Finger = %Loc(Fing_NoNode)
	    Else
		jnet_Finger = %Loc(Fing_Multj)
	    End if
	    Return
	End if
     
c  initialize hook to jnet

c  Turn on SYSPRV privilege
	Privilege(1) =  Prv$M_Sysprv
	Call Sys$Setprv(%Val(1),Privilege,,)
c  Create jnet HOOK
	Mode = 0
	Status = Jan_Hook_Init(Mode,' ')
c  Turn off SYSPRV privilege
	Call Sys$Setprv(,Privilege,,)
c  check status
        If (.Not.Status) then
	    If ( Status .eq. %Loc(Fing_jNA)) then
		jnet_Finger = %Loc(Fing_NoNet)
		Return
	    Else
		Call Lib$Signal(%Val(Status))
		jnet_Finger = %Loc(Fing_Abort)
		Return
	    End if
	End if

c  Format the timeout times
	Call Sys$BinTim(InitialTimeout,InitialTime)
	Call Sys$BinTim(Timeout,DeltaTime)

c  Format the line
	Line = Net_Command
	Len1 = BTrim(Net_Command)
	If ( Node_Type .eq. 'J' .or. Node_Type .eq. '*' ) then	! jnet and unix
	    Mode = 0
            User = ' '
	Else if ( Node_Type .eq. 'I' ) then		! IBM types a'la Vace
	    Mode = 2
            User = 'FINGER'
	    Line(1:6) = ' '	 	! get rid of "FINGER"
	    If ( Line .eq. ' ' ) Line = '*'
	    Line(Len1+1:Len1+4) = ' MSG' ! this so we get whole output
	    Len1 = Len1 + 4
        End if

c and send it out
c  Turn on WORLD privilege
	Privilege(1) =  Prv$M_World
	Call Sys$Setprv(%Val(1),Privilege,,)
        Status = Jan_Send_Msg(Mode,Next_Node,User,Line(:Len1))
c  Turn off WORLD privilege
	Call Sys$Setprv(,Privilege,,)
        If (.Not.Status) then
	    If ( Status .eq. %Loc(Rou_NoNode) ) then
		jnet_Finger = %Loc(Fing_NoNode)
		Goto 101
	    End if
	    Call Finger_Out_Routine(': link failed]'//CR//LF)
	    Call Lib$Signal(%Val(Status))
	    jnet_Finger = %Loc(Fing_Abort)
	    GoTo 101
	End if
     
c  clear timer flags
	Started = .false.
	TimedOut = .false.
c  Start the initial timeout
	Call Sys$SeTimr(,InitialTime,jnet_Timer_Ast,)
c  get the return messages
10      If ( Jan_Receive_Msg(Mode,Node,User,Line2,Len2) ) Goto 20
15	    If (started) Call Sys$SeTimr(,DeltaTime,jnet_Timer_Ast,)
	    Call Sys$Hiber()
	    Call Sys$CanTim(,)
	    If ( TimedOut ) GoTo 100
	    Goto 10
20	Continue
        If (Len2 .eq. 0) Go to 15
c  See if an intermediate node responded
	If ( Node .ne. Next_Node ) then
	    If ( .not. started ) 
	1   Call Finger_Out_Routine(': link failed]'//CR//LF)
	    Call Finger_Out_Routine(LF//'?Finger: Error from node '//
	1	Node//' - '//Line2(:Len2)//CR)
	    jnet_Finger = %Loc(Fing_Abort)
	    GoTo 101
	End if
c  Notify requester that link is open
	If ( .not. started ) then
c         Get network name
	    Network = Get_Network('J')
c         finish connection message
	    Call Finger_Out_Routine('.'//
	1	Network(:Btrim(Network))//']'//CR//LF)
	    started = .true.
	Endif
c  Output the line     
	Call Finger_Out_Routine(LF//Line2(:Len2)//CR)
c  Check for end of command
	If ( Index(Str$UpCase(Line2(:Len2)),
	1	'COMMAND COMPLETE').ne.0) 
	2	GoTo 100
c back for next line     
        Goto 10
     
c Here when done
100	Continue
	If ( .not. started ) then
	    Call Finger_Out_Routine(': link failed]'//CR//LF)
	    Call Finger_Out_Routine(LF//'?Finger: For node '//
	2		Next_Node//' - Timeout'//CR)
	    jnet_Finger = %Loc(Fing_Abort)
	End if
	Call Finger_Out_Routine(LF)
c  some last minute clean up
101	Call Sys$CanTim(,)
	Call Jan_Remove_Hook
	Return

1001	Format(Z8)

        End

c------------------------------------------------------------------------------
	Integer Function jnet_Timer_Ast

	Logical	TimedOut
	Common	/jnet_Common/ TimedOut

	TimedOut = .True.
	jnet_Timer_Ast = 1
	Call Sys$Wake(,)

	Return

	End

c------------------------------------------------------------------------
	Integer Function Local_Finger(Command,Finger_Out_Routine)

	Character VersionMsg*51
	Common	/Version_Common/ VersionMsg

	External	Finger_Out_Routine

	Character	Command*(*)
	Character*50	Directory
	Character	Name*25,	Get_PersonalName*25
	Character	Make_Pretty*25
	Character	ComName*12, Get_Username*12, TComName*12
	Character	CR /13/, LF /10/, NUL/0/, Flush/255/
	Integer		SS$_Status, Sys$Waitfr, Btrim
	Integer*2	NewMes
	Integer		LastLogin(2)
	Integer		TestOutput,	FlagProcess
	Logical		ValidID,	Validata_ID,	TestName
	Logical		Get_ID,		Check_Name,	Check_Process
	Logical		LoggedIn,	HeaderWritten
	External lbr$output_help, lib$get_input, lib$put_output
	Integer		Lbr$Ini_Control,Lbr$Open,	Lbr$Get_Help
	Integer		LbrIndex,	LbrFunc,	Lbr$C_Read/1/
	External	Fing_Complete,	Fing_Abort
	External	Do_Help
	Character	CCC*8
	Integer		Privilege(2) /0,0/

C  Include all GETJPI and flag definitions
	Include		'GETJPIDEF.FOR'
	Include		'FingerFlg.For'
	Include		'Fingerdef.Inc'

	structure /itmlist/
	 union
	  map
	   integer*2 bufferlen
	   integer*2 itemcode
	   integer*4 bufferaddr
	   integer*4 lengthaddr
	  end map
	  map
	   integer*4 endlist
	  end map
	 end union
	end structure

	character*12 username_uai
	include '($uaidef)'

	record /itmlist/ uai_list(2)

	uai_list(1).bufferlen = 12
	uai_list(1).itemcode = uai$_username
	uai_list(1).bufferaddr = %loc(username_uai)
	uai_list(2).endlist = uai$c_listend

c  Set default return status
	Local_Finger = %Loc(Fing_Complete)
c  initialize a few things
	l_Com = Len(Command)

C  Parse command
	Call Parse_Command(Command(:l_Com),ComName,
	1		TestName,TestOutput)

c  Print version if required
	If ( (TestOutput.and.FlagVersion) .ne. 0 ) Then
	    Call Finger_Out_Routine(LF//VersionMsg//CR)
	EndIf

c Output HELP if required
	If ( (TestOutput.and.FlagHelp) .ne. 0 ) Then
	    Call Header_Brief(Finger_Out_Routine)
c	    LbrFunc = Lbr$C_Read
c	    ii = Lbr$Ini_Control(LbrIndex,LbrFunc)
c	    If ( .not. ii ) then
c		Call Lib$Signal(%Val(ii_stat1))
c		Local_Finger = %Loc(Fing_Abort)
c		Return
c	    End if
c	    ii = Lbr$Open(LbrIndex,'SYS$HELP:HELPLIB.HLB')	
c	    If ( .not. ii ) then
c		Call Lib$Signal(%Val(ii_stat2))
c		Call Lbr$Close(LbrIndex)
c		Local_Finger = %Loc(Fing_Abort)
c		Return
c	    End if
c	    ii = Lbr$Get_Help(LbrIndex,,Do_Help,
c	1	Finger_Out_Routine,'FINGER...') 
c	    If ( .not. ii ) then
c		Call Lib$Signal(%Val(ii_stat3))
c		Call Lbr$Close(LbrIndex)
c		Local_Finger = %Loc(Fing_Abort)
c		Return
c	    End if
c	    Call Finger_Out_Routine(LF)
c	    Call Lbr$Close(LbrIndex)
c
	ii = Lbr$output_help( lib$put_output,,'FINGER',
     1  ,, lib$get_input)
	If (.not.ii) call exit(ii)
	    Return
	EndIf

	LoggedIn = .False.
c	If ( (Testoutput.and.FlagIdleTime) .ne. 0 )
c	1	Call Get_Idle_Times
c always try to get idletimes
c this way we ensure DECnet nodes are found also
	Call Get_Idle_Times

C  Set up item list
	I = 1					! 1st item - process name
	II = 1
	ITEM_LIST2(II+IC) =	JPI$_PRCNAM
	ITEM_LIST2(II+BL) =	L_PRCNAM
	ITEM_LIST(I+BA)  =	%LOC(PRCNAM)
	ITEM_LIST(I+RL)  =	%LOC(RL_PRCNAM)
	I = I + 3				! 2nd item - status flags
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_STS
	ITEM_LIST2(II+BL) =	L_STS
	ITEM_LIST(I+BA)  =	%LOC(STS)
	ITEM_LIST(I+RL)  =	%LOC(RL_STS)
	I = I + 3				! 3rd item - terminal name
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_TERMINAL
	ITEM_LIST2(II+BL) =	L_TERMINAL
	ITEM_LIST(I+BA)  =	%LOC(TERMINAL)
	ITEM_LIST(I+RL)  =	%LOC(RL_TERMINAL)
	I = I + 3				! 4th item - username
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_USERNAME
	ITEM_LIST2(II+BL) =	L_USERNAME
	ITEM_LIST(I+BA)  =	%LOC(USERNAME)
	ITEM_LIST(I+RL)  =	%LOC(RL_USERNAME)
	I = I + 3				! 5th item - PID
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_PID
	ITEM_LIST2(II+BL) =	L_PID
	ITEM_LIST(I+BA)  =	%LOC(PID)
	ITEM_LIST(I+RL)  =	%LOC(RL_PID)
	I = I + 3				! 6th item - GRP
	II = II + 6
	ITEM_LIST2(ii+IC) = 	JPI$_GRP
	ITEM_LIST2(ii+BL) =	L_PID
	ITEM_LIST(i+BA)  =	%LOC(GRP)
	ITEM_LIST(i+RL)  =	%LOC(RL_GRP)
	I = I + 3				! 7th item - OWNER
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_OWNER
	ITEM_LIST2(II+BL) = 	L_OWNER
	ITEM_LIST(I+BA)  =	%LOC(OWNER)
	ITEM_LIST(I+RL)  = 	%LOC(RL_OWNER)
	I = I + 3				! 8th item - STATE
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_STATE
	ITEM_LIST2(II+BL) =	L_STATE
	ITEM_LIST(I+BA) =	%LOC(STATE)
	ITEM_LIST(I+RL) =	%LOC(RL_STATE)
	I = I + 3				! 9th item - Global pages
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_GPGCNT
	ITEM_LIST2(II+BL) =	L_GPGCNT
	ITEM_LIST(I+BA) =	%LOC(GPGCNT)
	ITEM_LIST(I+RL) =	%LOC(RL_GPGCNT)
	I = I + 3				! 10th item - process pages
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_PPGCNT
	ITEM_LIST2(II+BL) =	L_PPGCNT
	ITEM_LIST(I+BA) =	%LOC(PPGCNT)
	ITEM_LIST(I+RL) =	%LOC(RL_PPGCNT)

	I = I + 3				! End of list
	ITEM_LIST(I) = 0

C  Print header
	If ( TestName ) Then
		Call Header_Brief(Finger_Out_Routine)
	Else
		Call Header_Full(TestOutput,Finger_Out_Routine)
	EndIf

C  Call $GetJpi service in loop
	PIDinput = PID_Wildcard
	HeaderWritten = .false.

c  Turn on WORLD privilege
	Privilege(1) = Prv$M_World
	Call Sys$Setprv(%Val(1),Privilege,,)

	DoWhile(Sys$Getjpi(,PIDinput,,Item_List,,,)) ! assume only failure
	    call sys$waitfr()			      ! is SS$_NoMoreProc
	    If ( Check_Process(TestOutput,FlagProcess,
	1	STS,GRP,Owner,Terminal) )
	1   Then
		If (.not. TestName .or.
	1	Check_Name(Username(:Btrim(Username)),
	2		ComName(:Btrim(ComName)) ) ) Then
		    LoggedIn = .true.
	            If ( (TestOutput .and. FlagSort) .ne. 0 ) Then
                        Call Make_Info(PID,STS,Prcnam,Username,Terminal,
	1                  State, GPgCnt+PPgCnt, HeaderWritten,
	2                  TestOutput, FlagProcess)
		    Else
		        Call User_Info(PID,STS,Prcnam,Username,Terminal,
	1		    State, GPgCnt+PPgCnt, HeaderWritten,
	2		    TestOutput,FlagProcess,Finger_Out_Routine)
		    EndIf
c		    Call User_Info(PID,STS,Prcnam,Username,Terminal,
c	1		State, GPgCnt+PPgCnt, HeaderWritten,
c	2		TestOutput,FlagProcess,Finger_Out_Routine)
		EndIf
	    EndIf
	EndDo
c  Ship out the entire user array
        If ( (TestOutput .and. FlagSort) .ne. 0 ) Then
	    Call Show_Info(HeaderWritten, Finger_Out_Routine,
	1                  TestOutput)
	EndIf

c  Turn off WORLD privilege
	Call Sys$Setprv(,Privilege,,)

	If ( .not. TestName .and. .not. LoggedIn )
	1   Call Finger_Out_Routine(LF//' no such jobs.')

200	Continue

C  Check if personal information is requested

	If (testname) then

c  Check to see if Fingeree is in the UAF
c  Turn on SYSPRV privilege
	  Privilege(1) = Prv$M_Sysprv
	  Call Sys$Setprv(%Val(1),Privilege,,)

	  call sys$getuai(,,ComName,uai_list,,,)

c  Turn off SYSPRV privilege
	  Call Sys$Setprv(,Privilege,,)

	  ValidId = (ComName.eq.username_uai)	!ValidId if in UAF
	endif

c  If the Fingeree isn't logged in then
c    If the Fingeree isn't in the UAF see if a match can be found in the
c       Finger Common Block
c    else see if the Finger is in the FCB.

	if (testname.and.(.not.loggedin)) then
	  If (.not.(validId)) then
	    TComName = Get_Username(ComName(:btrim(ComName)),
	1		NMatches,.true.,Finger_Out_Routine)
	    If ( NMatches .eq. 0 ) Call Finger_Out_Routine(LF//
	2		ComName(1:btrim(ComName))//
	3		': no such user.'//CR)
	  Else
	    name = Get_PersonalName(ComName(:Btrim(ComName)))
	    If (name.eq.' ') then
	      Call Finger_Out_Routine(LF//
	1	    ComName(1:btrim(ComName))//
	3	    ' is not logged in.'//CR)
	    Else 
	      Name = Make_Pretty(Name)
	      Call Finger_Out_Routine(LF//
	1	    ComName(1:btrim(ComName))//
	2	    ' ('//Name(1:btrim(Name))//')'//
	3	    ' is not logged in.'//CR)
	    EndIf
	  EndIf
	Endif

C  Print out Mail info and Plan if user is valid
	IF (TestName .and. ValidID ) Then
	    Call Personal_Info(ComName,	LoggedIn, 
	1	TestOutput,Finger_Out_Routine)
	EndIf

C  1 last line-feed at end
	Call Finger_Out_Routine(LF)

	Return

1000	Format(A)

	END


c---------------------------------------------------------------------------
	Subroutine Parse_Command(Command,ComName,
	1		TestName,TestOutput)

c  Note: this routine uses a command definition table which is created
c  by the SET COMMAND command from the file FINGERCLI.CLD.  Changes
c  to qualifiers etc. should be reflected both here and in that file.

	Include		'GETJPIDEF.FOR'
	Include		'FingerFlg.For'

c ** Site-Specific
c  Uncomment next for BYPASS logic
c	COMMON /BCZCOM/ FLAG_BYPASS
c	LOGICAL FLAG_BYPASS

	Character	Command*(*),	ComName*12
	Character	CR /13/, LF /10/, NUL/0/

	Logical		TestName 
	Integer		TestOutput

	External	FingerCli_Table
	Integer		Cli$Dcl_Parse,	Cli$Get_Value,	Cli$Present
	Integer		Kludge_Cli$Dcl_Parse, SortField, l_SortType
	Integer Btrim

	Character	CCC*8, SortType*20

	Common	/Sorter/ SortType, SortField

	TestName = .true.
	TestOutput = 0

	l_Com = Len(Command)
c  In V4.0 the next line would corrupt the stack
c  the Kludge... routine pads the stack first for protection
c	Call Cli$Dcl_Parse(Command(:l_Com),FingerCli_Table)
	Call Kludge_Cli$Dcl_Parse(Command(:l_Com),FingerCli_Table)
	ComName = ' '
	Call Cli$Get_Value('FINGERNAME',ComName)
	If ( ComName .eq. ' ' ) TestName = .false.
	If ( ComName .eq. '.' ) then
	    I = 1
	    II = 1
	    ITEM_LIST2(II+IC) =	JPI$_USERNAME
	    ITEM_LIST2(II+BL) =	L_USERNAME
	    ITEM_LIST(I+BA)  =	%LOC(USERNAME)
	    ITEM_LIST(I+RL)  =	%LOC(RL_USERNAME)
	    ITEM_LIST(I+3) = 0		! End of list
	    Call Sys$Getjpiw(,,,Item_List,,,)
	    ComName = Username
	End if

c  Set flags from command qualifiers
	If ( Cli$Present('INTERACTIVE') ) 
	1	TestOutput = TestOutput .or. FlagInteractive
	If ( Cli$Present('BATCH') )
	1	TestOutput = TestOutput .or. FlagBatch
	If ( Cli$Present('SUBPROCESS') )
	1	TestOutput = TestOutput .or. FlagSubprocess
	If ( Cli$Present('NETWORK') )
	1	TestOutput = TestOutput .or. FlagNetwork
	If ( Cli$Present('SYSTEM') )
	1	TestOutput = TestOutput .or. FlagSystem
	If ( Cli$Present('ALL') )
	1	TestOutput = TestOutput .or. FlagAll
	If ( Cli$Present('HELP') )
	1	TestOutput = TestOutput .or. FlagHelp
C ** Site-Specific
C uncomment next for bypass switch
c		FLAG_BYPASS = .FALSE.				! BCZ
c	If ( Cli$Present('BYPASS') )				! BCZ
c	1	FLAG_BYPASS = .TRUE.				! BCZ

c  If nothing else on, turn on FlagInteractive
c  & also batch, subprocess flags.
	If ( TestOutput .eq. 0 )
     1   TestOutput = FlagInteractive .or. FlagBatch .or. 
     2   FlagSubprocess

c  Miscellaneous stuff
	If ( Cli$Present('SORT') ) Then
	    TestOutput = TestOutput .or. FlagSort
	    Call Cli$Get_Value('SORT', SortType)
	    l_SortType = Btrim(SortType)
	    If (index('LAST_NAME', SortType(:l_SortType)) .eq. 1) then
		SortField = 0
	    Else If (index('USER_NAME', SortType(:l_SortType)) .eq. 1) then
		SortField = 1
	    Else If (index('PROCESS_NAME', SortType(:l_SortType)) .eq. 1) then
		SortField = 2
	    Else If (index('PID', SortType(:l_SortType)) .eq. 1) then
		SortField = 3
	    Else If (index('TERMINAL', SortType(:l_SortType)) .eq. 1) then
		SortField = 4
	    Else If (index('LOGIN_TIME', SortType(:l_SortType)) .eq. 1) then
		SortField = 5
	    Else If (index('IMAGE', SortType(:l_SortType)) .eq. 1) then
		SortField = 6
	    Else
		SortType = 'Default'
		SortField = 0
	    EndIf
	EndIf
	If ( Cli$Present('VERSION') )
	1	TestOutput = TestOutput .or. FlagVersion
	If ( Cli$Present('MESSAGE') )
	1	TestOutput = TestOutput .or. FlagMessage

c  individual's stuff
	If ( Cli$Present('PLAN') )
	1	TestOutput = TestOutput .or. FlagPlan
	If ( Cli$Present('MAIL') )
	1	TestOutput = TestOutput .or. FlagMail

c  display qualifiers
	If ( Cli$Present('PID') )
	1	TestOutput = TestOutput .or. FlagPid
	If ( Cli$Present('PROCESSNAME') )
	1	TestOutput = TestOutput .or. FlagProcessname
	If ( Cli$Present('USERNAME') )
	1	TestOutput = TestOutput .or. FlagUsername
	If ( Cli$Present('PERSONALNAME') )
	1	TestOutput = TestOutput .or. FlagPersonalName
	If ( Cli$Present('IMAGENAME') )
	1	TestOutput = TestOutput .or. FlagImagename
	If ( Cli$Present('TERMINAL') )
	1	TestOutput = TestOutput .or. FlagTerminal
	If ( Cli$Present('LOGINTIME') )
	1	TestOutput = TestOutput .or. FlagLoginTime
	If ( Cli$Present('CPUTIME') )
	1	TestOutput = TestOutput .or. FlagCpuTime
	If ( Cli$Present('STATE') )
	1	TestOutput = TestOutput .or. FlagState
	If ( Cli$Present('SIZE') )
	1	TestOutput = TestOutput .or. FlagSize
	If ( Cli$Present('IDLETIME') )
	1	TestOutput = TestOutput .or. FlagIdleTime
	If ( Cli$Present('LOCATION') )
	1	TestOutput = TestOutput .or. FlagLocation
	If ( Cli$Present('TTTYPE') )
	1	TestOutput = TestOutput .or. FlagTTType
	If ( Cli$Present('SWAPPED') )
	1	TestOutput = TestOutput .or. FlagSwapped
c  lastly test for /FULL : it turns all displays on
	If ( Cli$Present('FULL') )
	1	TestOutput = TestOutput .or. FlagFull

	Return
	End

c---------------------------------------------------------------------------
	Logical Function Do_Help(Line,HelpFlags,Out_Routine,Level)

	External	Out_Routine

	Character	CR /13/, LF /10/, NUL/0/
	Character	Line*(*),	Space*80/' '/
	Integer		HelpFlags,	Level

	l_Line = Len(Line)

	Call Out_Routine(LF//
	1	Space(:5*(Level-1)+1)//Line(:l_Line)//CR)

	Do_Help = .true.
	Return

	End

c---------------------------------------------------------------------------
	Logical Function Check_Process(TestOutput,FlagProcess,
	1				STS,GRP,Owner,Terminal)

	Character	Terminal*8
	Character	NUL/0/

	Integer		STS,	GRP,	Owner
	Integer		Pcb$m_Batch/Z00004000/
	Integer		Pcb$m_Netwrk/Z00200000/

	Integer		FlagProcess
	Integer		TestOutput

	Include		'FingerFlg.For'

	Parameter	SysGRP = 8

	FlagProcess = 0
	Check_Process = .true.

c  set process flags
	If ( Terminal(1:1) .ne. NUL ) Then
	    FlagProcess = FlagProcess .or. FlagInteractive
	ElseIf ( (STS.and.Pcb$m_Batch) .ne. 0 ) Then
	    FlagProcess = FlagProcess .or. FlagBatch
	ElseIf ( (STS.and.Pcb$m_Netwrk) .ne. 0 ) Then
	    FlagProcess = FlagProcess .or. FlagNetwork
	ElseIf ( Owner .ne. 0 ) Then
	    FlagProcess = FlagProcess .or. FlagSubprocess
	ElseIf ( GRP .le. SysGRP ) then
	    FlagProcess = FlagProcess .or. FlagSystem
	Else
	EndIf

c  First check for "/ALL"
	If ( (TestOutput.and.FlagAll) .ne. 0 ) Return

c Check process against flags
	If ( (TestOutput.and.FlagProcess) .eq. 0 ) 
	1	Check_Process = .false.

	Return
	End

c---------------------------------------------------------------------------
	Subroutine Header_Full(TestOutput,Finger_Out_Routine)

	include		'($syidef)'
	Include		'FingerCom'
	Include		'FingerFlg'
	Include		'Finger_Context'
	Integer		TestOutput

	External	Finger_Out_Routine

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

	Common	/IO_Units/ 
	1		OutboundLinkUnit,
	2		UafUnit,
	3		ScratchUnit


c  Site-specific: load pseudodevice gives load averages.
	Parameter	LoadDevice = 'LAV0:'
c	Parameter	LoadDevice = '$$VMS_LOAD_AVERAGE:'	! alternate

	Integer		SS$_Status, SS$_NoLog/Z000001BC/
	Integer		Sys$AscTim, Sys$GetTim, Sys$TrnLnm, Sys$GetSYIW
	Integer		Btrim
	Integer		TRN_ItemList(4)
	Integer*2	TRN_ItemList2(8)
	Equivalence	(TRN_ItemList,TRN_ItemList2)
	Integer		TRN$_String /Z00000002/
	Character*4	CPU_Type
	Integer		l_CPU, l_Vrsn
	Character	System_Version*8
	Character	Node$Lognam*8 /'SYS$NODE'/,	Node*12
	Character	AscTime*23, AscSince*23, Make_Pretty*23
	Character	AscDelsince*23 ! gce retrofit
	Character	Day_OfTheWeek*9, Today*9, Upday*9
	Character	MsgLine*132
	Real		Load1,	load5,	load15

	External	Sys$gw_IJobCnt
	External	Sys$gw_BJobCnt
	External	Exe$gl_AbsTim
	External	Priv_UserOpen
	Integer*2	Get_w_Val
	Integer		Get_l_Val
	Integer		Ijobs, Bjobs 
	Integer		UpTime(2), SysTime(2), UpSince(2)

	Character	NUL/0/, LF/10/, CR /13/, SP /' '/
	Character	Temp*23
	Logical		LoadAvailable	/.false./
	Logical		WroteSomething	/.false./

	structure /itmlist/
	 union
	  map
	   integer*2 bufferlen
	   integer*2 itemcode
	   integer*4 bufferaddr
	   integer*4 lengthaddr
	  end map
	  map
	   integer*4 endlist
	  end map
	 end union
	end structure

	record /itmlist/ syi_list(3)

C  Get node name, system stuff, time, load averages etc., print header

c  Set up item list for GetSYI and call it. It returns a four character
c  cpu type, e.g., 2000, V780, 8300, 8530, 8700, 8800...

	syi_list(1).bufferlen = 4
	syi_list(1).itemcode = syi$_node_hwtype
	syi_list(1).bufferaddr = %loc(CPU_Type)
	syi_list(2).bufferlen = 8
	syi_list(2).itemcode = syi$_Version
	syi_list(2).bufferaddr = %loc(System_Version)
	syi_list(2).lengthaddr = %loc(l_vrsn)
	syi_list(3).endlist = syi$c_listend

	Call Sys$GetSYIW(,,,SYI_list,,,)

c Rip off the V if it has one (V7xx)

	If (CPU_Type(1:1).eq.'V') CPU_Type(1:1) = ' '

	TRN_ItemList2(1) = 8
	TRN_ItemList2(2) = TRN$_String
	TRN_ItemList(2) = %Loc(DECnet_Node)
	TRN_ItemList(3) = %Loc(L_node)
	TRN_ItemList2(7) = 0
	TRN_ItemList2(8) = 0

	SS$_Status = Sys$TrnLnm(,'LNM$SYSTEM_TABLE',
	1	Node$Lognam,1,
	3	TRN_ItemList)

	If ( Net$C_Local_Host_Name .eq. ' ' ) then
	    If ( SS$_Status .eq. SS$_NoLog ) Then
		Node = 'Finger'
	    Else
		Node = DECnet_Node(:l_Node-2)
	    EndIf
	Else
	    Node = Net$C_Local_Host_Name		! use set value
	End if
	l_Node = Btrim(Node)
	Call Sys$AscTim(,AscTime,,)				! Time now
	AscTime = Make_Pretty(AscTime)
	Today = Day_OfTheWeek(%Val(0))
	UpTime(1) = Get_l_Val(Exe$gl_AbsTim)			! up time (sec)
	Call Lib$EMul(10000000,UpTime,0,UpTime)			! 64 bit format
	Call Sys$GetTim(SysTime)
	Call Lib$Subx(SysTime,UpTime,UpSince)
	Call Sys$AscTim(,AscSince,UpSince,)			! Up since
	AscSince = Make_Pretty(AscSince)
c  get delta time to ASCII format ... then shift out spaces  ! gce retrofit
	Call Lib$Subx(Updelta,UpTime,Updelta) ! gceretro
	Call Sys$AscTim(,Ascdelsince,updelta,) !gce retro
	i_nospace = 1 ! gce retrofit
	do while (ascdelsince(i_nospace:i_nospace) .eq. ' ')  !gce retro
		i_nospace = i_nospace + 1  !gce retro
	end do
	Upday = Day_OfTheWeek(UpSince)
	Ijobs = Get_w_Val(Sys$gw_IJobCnt)			! # users
	Bjobs = Get_w_Val(Sys$gw_BJobCnt)			! # batch

c  ! Site-specific: This is the load average pseudo-device.  If not
c  available, omit this section.  Or leave it and it will still be OK.
	Open(Unit=ScratchUnit,
	1	File=LoadDevice,
	2	Type='NEW',
	3	RecordSize=36,
	4	Err=101)
	Read(ScratchUnit,2000,Err=101) Load1, Load5, Load15
	Close(Unit=ScratchUnit)
	LoadAvailable = .true.
101	Continue

C  Print full header
C		Organization name if defined
	If ( Net$C_Organization .ne. ' ' )
	1	Call Finger_Out_Routine(
	2	LF//
	3	Net$C_Organization(:BTrim(Net$C_Organization))//
	4	CR)
C		1st full line
	Call Finger_Out_Routine(LF//
	1			Node(:l_Node)//' VAX '//
	2			CPU_Type//', '//
	4			'VMS '//
	5		 	System_Version(:Btrim(System_Version))//
	6			'. '//
	7			Today(:Btrim(Today))//', '//
	8			AscTime(:17)//', ')
	If ( Ijobs .eq. 1 ) then
	    Write(Temp,1001)	Ijobs, ' User, '
	Else
	    Write(Temp,1001)	Ijobs, ' Users, '
	End if
	Call Finger_Out_Routine(Temp(:10))
	Write(Temp,1001)	Bjobs, ' Batch.'
	Call Finger_Out_Routine(Temp(:9))
	Call Finger_Out_Routine(CR)
c		2nd line
	Call Finger_Out_Routine(LF//
	1			' Uptime '//Ascdelsince(i_nospace:10)//
	2			' Since '//
	3			Upday(:Btrim(Upday))//', '//
	4			AscSince(:17))
	If ( LoadAvailable ) Then
	    Write(Temp,1002) 	', Load: '	! Site-specific
	1			,Load1 		! Site-specific
	2    			,Load5		! Site-specific
	3    			,Load15		! Site-specific
c	    Call Finger_Out_Routine(Temp(:13))
	    Call Finger_Out_Routine(Temp)
	EndIf
	Call Finger_Out_Routine(CR//LF)

C  Print message if any
	If ( (TestOutput.and.FlagMessage) .ne. 0 ) then
	    Open	(Unit=ScratchUnit,
	1	File='FINGER$MESSAGE:',
c	2	UserOpen = Priv_UserOpen, ! Uncomment this to prevent
c					! redirection of message lognamm
	2	Type='OLD',
	3	ReadOnly,
	4	Shared,
	5	Err=201)
	    DoWhile(.True.)		! Loop through message file
		Read(ScratchUnit,3000,Err=201,End=200) l_Msg, MsgLine
		Call Finger_Out_Routine(LF//MsgLine(:l_Msg)//CR)
		WroteSomething = .True.
	    EndDo
200	    Call Priv_Close(ScratchUnit)
201	    Continue
C	    1 blank line if there was any message
	    If ( WroteSomething ) Call Finger_Out_Routine(LF//CR)
	EndIf

	Return

1001	Format(I2,A)
1002	Format(A,3F5.2)

2000	Format(3A4)

3000	Format(Q,A)	

	End


c---------------------------------------------------------------------------
	Subroutine Header_Brief(Finger_Out_Routine)

	Include		'Fingercom'
	Include		'Finger_Context'

	External	Finger_Out_Routine

	Integer		TRN$_String /Z00000002/
	Integer		TRN_ItemList(4)
	Integer*2	TRN_ItemList2(8)
	Equivalence	(TRN_ItemList,TRN_ItemList2)

	Integer		SS$_Status, SS$_NoLog/Z000001BC/
	Integer		Sys$AscTim, Sys$GetTim, Sys$TrnLnm
	Integer		Btrim
	Character	Node$Lognam*8 /'SYS$NODE'/,	Node*9
	Character	Day_OfTheWeek*9,	Today*9
	Character	AscTime*23, Make_Pretty*23

	Character	NUL/0/, LF/10/, CR /13/, SP /' '/

C  Get node name, system time
	TRN_ItemList2(1) = 8
	TRN_ItemList2(2) = TRN$_String
	TRN_ItemList(2) = %Loc(DECnet_Node)
	TRN_ItemList(3) = %Loc(L_node)
	TRN_ItemList2(7) = 0
	TRN_ItemList2(8) = 0

	SS$_Status = Sys$TrnLnm(,'LNM$SYSTEM_TABLE',
	1	Node$Lognam,1,
	3	TRN_ItemList)

	If ( Net$C_Local_Host_Name .eq. ' ' ) then
	    If ( SS$_Status .eq. SS$_NoLog ) Then
		Node = 'Finger'
	    Else
		Node = DECnet_Node(:l_Node-2)
	    EndIf
	Else
	    Node = Net$C_Local_Host_Name		! use set value
	End if
	l_Node = Btrim(Node)
	Call Sys$AscTim(,AscTime,,)			! Time now
	AscTime = Make_Pretty(AscTime)
	Today = Day_OfTheWeek(%Val(0))

C  Print brief header
	Call Finger_Out_Routine(LF//
	1			Node(:l_node)//
	2			' VAX/VMS, '//
	3			Today(:Btrim(Today))//', '//
	4			AscTime(:17)//
	5			CR//LF)

	Return
	End

c---------------------------------------------------------------------------
	Logical	Function Check_Name(Username,ComName)

c  Check if the Username of a process matches the name from the
c  input command.

	Logical		Wild_Match
	Character	Username*(*), ComName*(*)

	Check_Name = .false.

	If ( Username .eq. ComName ) Then
	    Check_Name = .true.
	    Return
	EndIf

c  Check for wild-card
	Check_Name = Wild_Match(ComName,Username)

	Return
	End


c-----------------------------------------------------------------------------
	Subroutine User_Info(PID,STS,Prcnam,Username,Terminal,
	1	State, PgCnt, HeaderWritten,
	2	TestOutput,FlagProcess,Finger_Out_Routine)

	External	Finger_Out_Routine

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

	Common	/IO_Units/ 
	1		OutboundLinkUnit,
	2		UafUnit,
	3		ScratchUnit
	
	Include		'GETJPIDEF'
	Include		'FingerFlg'
	Include		'Fingerdef.Inc'

	Integer		TestOutput,	FlagProcess
	Integer		CPU_Min,	CPU_Sec
	Character	PID_String*8
	Character	Location*25,	Get_Location*25
	Character	Make_Pretty*20,	Filter_Control_Chars*15
	Character	Name*20,	Get_PersonalName*20
	Character	Image*9,	Get_Image*9
	Character	Time_String*11,	Login_Time*5
	Character	CPU_Time*6,	Idle_Time*5,	Get_Idle*5
	Character	TTType*25
	Character	Quename*18
	Character	CR /13/, LF /10/
	Integer		PgCnt
	Character*5	States(15) /
	1	'ColPg','MWait',' CEF ',' PFW ',' LEF ',' LEFO',' Hib ',
	1	' HibO',' Susp','SuspO',' FPg ',' Com ',' ComO',' Cur ',
	1	'     '/
	Integer		LEF_State /5/, Blank_State /15/
	Integer		State_COMO /13/, State_HIBO /8/
	Integer		State_LEFO /6/, State_SUSPO /10/
	Character*5	Size
	Logical		HeaderWritten 
	Integer		Privilege(2) /0,0/
	character*31	get_queue, queue_name

c  ! site-specific
c  Note - this routine is set up so you can select the information
c  you desire printed.  Set the defaults for your site in the FINGERCLI.CLD
c  file.  The user can override these with explicit qualifiers to the
c  FINGER command. If all fields are selected the line is 135 characters long
c  (3 more for long terminal line number).  You could vary the size of certain 
c  fields (e.g. PERSONALNAME or LOCATION) if you wanted to customize things
c  further.  I use only 15 out of 25 characters of the location, and the TTType
c  may wrap.  The size of these could be varied.  I would never use certain 
c  combinations together, e.g. PROCESSNAME and USERNAME (they are practically
c  redundant) - but to each his own. (USERNAME is useful for MAIL and PHONE, 
c  PROCESSNAME is unique.) 		- Rg

c  first some petty preprocessing
	If ( (Testoutput.and.FlagPID) .ne. 0 ) then
	    Write(PID_String,1001) PID
	    Do II = 1,8
		If ( PID_String(II:II) .eq. ' ') PID_String(II:II) = '0'
	    End do
	End if
	Call NULToSP(Terminal,8)
	If ( (Testoutput.and.FlagProcessname) .ne. 0 ) then
	    Call NULToSP(Prcnam,15)
	    Prcnam = Filter_Control_Chars(Prcnam)
	End if
	If ( (Testoutput.and.FlagPersonalName) .ne. 0 )
	1   Name = Make_Pretty(Get_PersonalName(Username))
c  only get P1 stuff for inswapped processes unless asked otherwise
	If ( (Testoutput.and.FlagSwapped) .ne. 0 ) then
	    Image = Make_Pretty(Get_Image(PID,LoginTim,CPUTim))
	Else
           IF (	State .ne. State_COMO .and.
	1	State .ne. State_HIBO .and.
	2	State .ne. State_LEFO .and.
	3	State .ne. State_SUSPO) then
		Image = Make_Pretty(Get_Image(PID,LoginTim,CPUTim))
	    Else
		Image = '<swapped>'
		Logintim(1)= 0
		Logintim(2)= 0
		CPUTim=      0
	    End if
	End if
c  If in DCL and LEF state, don't print STATE. (keep picture cleaner)
	If (Image.eq.'$' .and. State.eq.LEF_State ) State = Blank_State
	Call Sys$Asctim(,Time_String,LoginTim,%Val(1))
	Login_Time = Time_String(1:5)
c  convert CPU time to min and sec
	CPU_Sec = CPUTim/100
	CPU_Min = CPU_Sec/60
	CPU_Sec = CPU_Sec - (60*CPU_Min)
	If ( CPU_Min .le. 999 ) then
	    Write(CPU_Time,1002) CPU_Min, CPU_Sec
	    If ( CPU_Time(5:5) .eq. ' ' ) CPU_Time(5:5) = '0'
	Else
c  if more than 999 min, omit seconds
	    Write(CPU_Time,10021) CPU_Min
	Endif
c  scratch Login and CPU time for outswapped processes
	If ( Image(1:1) .eq. '<' ) Login_Time = ' --- '
	If ( Image(1:1) .eq. '<' ) CPU_Time = '  --- '
c force getting idle ... try and get DECnet info read
	Idle_Time = Get_Idle(PID) ! gce mod
	If ( (Testoutput.and.FlagIdleTime) .ne. 0 )
	1	Idle_Time = Get_Idle(PID)
	Write(Size,1003) PgCnt
	Location = Get_Location(Terminal,TTType,PID)
	If ( (FlagProcess.and.FlagSubprocess) .ne. 0 ) then
	    Location = '- Subprocess -'
	    TTType = ' '
	Else If ( (STS.and.Pcb$m_Batch) .ne. 0 ) Then
c  Turn on SYSPRV privilege
	    Privilege(1) =  Prv$M_Sysprv
	    Call Sys$Setprv(%Val(1),Privilege,,)
c  get job controller information
	    queue_name = get_queue(pid)
c  Turn off SYSPRV privilege
	    Call Sys$Setprv(,Privilege,,)
	    Location = 'Q.'//queue_name
	    TTType = ' '
	End If
c  Column headings
	If ( .not. HeaderWritten ) Then
	    Call Finger_Out_Routine(LF)
	    If ( (Testoutput.and.FlagPID) .ne. 0 )
	1	Call Finger_Out_Routine('PID      ')
	    If ( (Testoutput.and.FlagProcessname) .ne. 0 )
	1	Call Finger_Out_Routine('Process         ')
	    If ( (Testoutput.and.FlagUsername) .ne. 0 )
	1	Call Finger_Out_Routine('Username     ')
	    If ( (Testoutput.and.FlagPersonalName) .ne. 0 )
	1	Call Finger_Out_Routine('Personal name        ')
	    If ( (Testoutput.and.FlagImagename) .ne. 0 )
	1	Call Finger_Out_Routine('Program   ')
	    If ( (Testoutput.and.FlagTerminal) .ne. 0 )
c	1	Call Finger_Out_Routine('Term ')	! short terminal name
	1	Call Finger_Out_Routine('Term     ')	! long terminal name
	    If ( (Testoutput.and.FlagLoginTime) .ne. 0 )
	1	Call Finger_Out_Routine('Login ')
	    If ( (Testoutput.and.FlagCPUTime) .ne. 0 )
	1	Call Finger_Out_Routine('  CPU  ')
	    If ( (Testoutput.and.FlagIdleTime) .ne. 0 )
	1	Call Finger_Out_Routine(' Idle ')
	    If ( (Testoutput.and.FlagState) .ne. 0)
	1	Call Finger_Out_Routine('State ')
	    If ( (Testoutput.and.FlagSize) .ne. 0)
	1	Call Finger_Out_Routine(' Size ')
	    If ( (Testoutput.and.FlagLocation) .ne. 0 )
	1	Call Finger_Out_Routine('Location        ')
	    If ( (Testoutput.and.FlagTTType) .ne. 0 )
	1	Call Finger_Out_Routine('TT Type')
	    Call Finger_Out_Routine(CR)
	    HeaderWritten = .true.
	EndIf

c  Write out line of user information

	Call Finger_Out_Routine(LF)
	If ( (Testoutput.and.FlagPID) .ne. 0 )
	1	Call Finger_Out_Routine(PID_String//' ')
	If ( (Testoutput.and.FlagProcessname) .ne. 0 )
	1	Call Finger_Out_Routine(Prcnam//' ')
	If ( (Testoutput.and.FlagUsername) .ne. 0 )
	1	Call Finger_Out_Routine(Username//' ')
	If ( (Testoutput.and.FlagPersonalName) .ne. 0 )
	1	Call Finger_Out_Routine(Name//' ')
	If ( (Testoutput.and.FlagImagename) .ne. 0 )
	1	Call Finger_Out_Routine(Image//' ')
	If ( (Testoutput.and.FlagTerminal) .ne. 0 )
c	1	Call Finger_Out_Routine(Terminal(1:4)//' ')	! short
	1	Call Finger_Out_Routine(Terminal(1:8)//' ')	! long
	If ( (Testoutput.and.FlagLoginTime) .ne. 0 )
	1	Call Finger_Out_Routine(Login_Time//' ')
	If ( (Testoutput.and.FlagCPUTime) .ne. 0 )
	1	Call Finger_Out_Routine(CPU_Time//' ')
	If ( (Testoutput.and.FlagIdleTime) .ne. 0 )
	1	Call Finger_Out_Routine(Idle_Time//' ')
	If ( (Testoutput.and.FlagState) .ne. 0)
	1	Call Finger_Out_Routine(States(State)//' ')
	If ( (Testoutput.and.FlagSize) .ne. 0)
	1	Call Finger_Out_Routine(Size//' ')
	If ( (Testoutput.and.FlagLocation) .ne. 0 )
	1	Call Finger_Out_Routine(Location(1:15)//' ')
	If ( (Testoutput.and.FlagTTType) .ne. 0 )
	1	Call Finger_Out_Routine(TTType)
	Call Finger_Out_Routine(CR)

	Return

1000	Format(A)
1001	Format(Z8)
1002	Format(I3,':',I2)
10021	Format(I6)
1003	Format(I5)

	End

c--------------------------------------------------------------------
	Subroutine Personal_Info(UserName, LoggedIn, 
	1	TestOutput, Finger_Out_Routine)

c   Routine to type a user's Mail info and PLAN file, given his name.
c   Adapted from routine "Type_Plan" written at CMU PSYA::
c  ! Site-specific note:  If you want different names for plan files,
c  change or add to the following list

	Include	 'Fingerdef.inc'
	Include	 'Finger_Context'
	Include	 'FingerFlg'
	Include  '($FORIOSDEF)'

c ** Site-Specific
c uncomment for BYPASS switch logic
c	COMMON /BCZCOM/ FLAG_BYPASS
c	LOGICAL FLAG_BYPASS

	Parameter PlanFileName1 = 'FINGER.PLN'
	Parameter PlanFileName2 = 'PLAN.'       ! compatible with EUNICE
c	Parameter PlanFileName3 = 'anything'    ! your choice
	External	Finger_Out_Routine

	Integer
	1	       OutboundLinkUnit,
	2	       UafUnit,
	3	       ScratchUnit
	Common  /IO_Units/
	1	       OutboundLinkUnit,
	2	       UafUnit,
	3	       ScratchUnit

	Byte		UAF_Record(1:UAF$K_Length)
	Byte		UAF_L_DefDev
	Equivalence	(UAF_L_DefDev,UAF_Record(Uaf$K_DefDev))
	Character	UAF_DefDev*(UAF$S_DefDev)
	Equivalence	(UAF_DefDev,UAF_Record(Uaf$T_DefDev))
	Byte		UAF_L_DefDir
	Equivalence	(UAF_L_DefDir,UAF_Record(Uaf$K_DefDir))
	Character	UAF_DefDir*(UAF$S_DefDir)
	Equivalence	(UAF_DefDir,UAF_Record(Uaf$T_DefDir))
	Integer		LastLogin(2), UAF_LastLogin(2)
	Equivalence	(UAF_LastLogin,UAF_Record(UAF$Q_LastLogin_I))
	Integer*2 	NewMes
c add longword UIC value also
	Integer*4	UICval
	Equivalence	(UICval,UAF_Record(UAF$K_UIC))

        Structure /VMSMAIL_Structure/
	union
	 map
	  byte		rec(2048)
	 end map
	 map
          Character	crec*2048
	 end map
	end union
        End Structure

        Record /VMSMAIL_Structure/ VMSMail_Record

	Structure /MAIL_Structure/
	 union
	  map
	   character	rec*3047
	  end map
	  map
	   integer*2	date(4)
	   character	%fill*1
	   character	folder*39
	   union
	    map
	     character	rest*3000
	    end map
	    map
	     integer*2	irest(1500)
	    end map
	   end union
	  end map
	 end union
	End Structure

	structure /itmlist/
	 union
	  map
	   integer*2 bufferlen
	   integer*2 itemcode
	   integer*4 bufferaddr
	   integer*4 lengthaddr
	  end map
	  map
	   integer*4 endlist
	  end map
	 end union
	end structure

	include		'($jpidef)'
	integer		sys$getjpiw
	character	you*12


	Character*64	Directory
	Character*128	Mail_Directory

	Logical	 LoggedIn
	Integer	 Status
	Integer	 SS$_Status
     
	Character       Temp*25, Sender*40
	Character*50    MailFile, PlanFile
	Character*12    UserName
	Character*9     Day_oftheWeek, LastLogin_Day, Mail_Day
	Character*70    LastLogin_Time, Make_Pretty
	Character*17	Mail_Time
	Character*132   Line
	Character*1     LF/10/, CR/13/
	Integer	 Btrim, Sender_len
	Integer	 TestOutput
	Integer*4       UserUIC,FlgUIC
	Common/UseUIC/UserUIC,FlgUIC
	External	Priv_UserOpen


	logical		foundmail
	character	subject*80,csize*2,tousername*12,from*80
	integer		size*2, ptr

	equivalence	(size,csize)

	record /itmlist/ jpi_itmlist(2)
	Record /MAIL_Structure/ mailrec

	character	maildir*256,cfn*2,cfnlen*2, 
	1		cnewmes*2
	integer		fn*2, fnlen*2
	logical		got_newmes, got_dir, got_subj
	equivalence	(cfn,fn)
	equivalence	(cfnlen,fnlen)
	equivalence	(cnewmes,newmes)

c First get stuff from UAF
c  open the UAF
	FlgUIC=0
c FlgUIC=0 to tell priv_useropen not to bother with UIC
	Open(Unit=UafUnit,
	1	File = 'SYSUAF',
	2	Default File = 'SYS$SYSTEM:.DAT',
	2	Err=999,
	3	User Open = Priv_UserOpen,
	4	Status = 'Old',
	5	Organization = 'Indexed',
	6	Access = 'Keyed',
	7	Form = 'Formatted',
	8	Readonly, 
	9	Shared)
c  read it
	Read(UafUnit,1000,KeyEq=UserName,Err=999) UAF_Record
c close it
	Call Priv_Close(UafUnit)
c   Concatenate the DEFDEV and DEFDIR into one string Directory.
	Directory = UAF_DefDev(:UAF_L_DefDev) //
	1		UAF_DefDir(:UAF_L_DefDir)
c  set up the last login stuff
	LastLogin(1) = UAF_LastLogin(1)
	LastLogin(2) = UAF_LastLogin(2)

c Save owner UIC
	UserUIC = UICval
     
C  Last Login info
	If ( .not. (LastLogin(1).eq.0 .and. LastLogin(2).eq.0) ) then
	  LastLogin_Day = Day_oftheWeek(LastLogin)
	  Call Sys$AscTim(,LastLogin_Time,LastLogin,)
	  LastLogin_Time = Make_Pretty(LastLogin_Time)
	  If ( LoggedIn ) then
	    Call Finger_Out_Routine(LF//' Logged in since: ')
	  Else
	    Call Finger_Out_Routine(LF//' Last logged in: ')
	  End if
	  Call Finger_Out_Routine(
	1      LastLogin_Day(:Btrim(LastLogin_Day))//', '//
	2      LastLogin_Time(:17)//CR)
	End if

C  Mail information
	If ( (TestOutput.and.FlagMail) .ne. 0 ) then
c    Now get VMSMAIL stuff (system-wide data)
	  Open ( Unit=ScratchUnit,
	1	File='VMSMAIL_PROFILE' ,
	1	Default File = 'SYS$SYSTEM:.DATA',
	1	Err = 99,
	1	UserOpen = Priv_UserOpen,
	2	Status='Old' ,
	3	Organization='Indexed' ,
	4	Access='Keyed' ,
	5	Form='Unformatted' ,
	7	Readonly ,
	8	Shared ,
	1	RecordType='Variable' )
c
	  newmes=0
	  got_newmes=.false.
	  got_dir=.false.
	  maildir=' '
	  ptr=32
	  fn=1	!non-zero

	  Read(	Unit=ScratchUnit, 
	1	KeyEQ=UserName, 
c	2	Err=99,
	3	KeyID=0, 
	4	IOStat=Status) VMSMAIL_Record

	  if (status.eq.FOR$IOS_ATTACCNON) goto 99
	  Call Priv_CLOSE (ScratchUnit)
c
c [rph] see VMSPROFILE_DATA.format for the struture of these records
c
	  do while ((.not.(got_newmes.and.got_dir)).and.(fn.ne.0))
	    cfn=vmsmail_record.crec(ptr:ptr+1)
	    cfnlen=vmsmail_record.crec(ptr+2:ptr+3)
	    if (fn.eq.1) then
	      cnewmes=vmsmail_record.crec(ptr+4:ptr+5)
	      got_newmes=.true.
	    else if (fn.eq.3) then
	      maildir=vmsmail_record.crec(ptr+4:ptr+4+fnlen-1)
	      got_dir=.true.
	    end if
	    ptr=ptr+4+fnlen
	  end do 

	  Call Finger_Out_Routine(LF//' Mail: ')
	  If (NewMes .gt. 0) then
            If (len(maildir).gt.0) Then
	      i_brak = Index(maildir,'[')
              Mail_Directory = Directory(:(BTrim(Directory)-1))//
	1		       maildir(i_brak+1:BTrim(maildir))
	    Else 
	      Mail_Directory = Directory
	    EndIf

	    Temp = ' '
	    If ( NewMes .eq. 1 ) then
	      Call Finger_Out_Routine('1 new message.'//CR)
	    ElseIf ( NewMes .gt. 1 .and. NewMes .lt. 10 ) then
	      Write(Temp,1001)NewMes,' new messages.'//CR
	      Call Finger_Out_Routine(Temp(:16))
	    ElseIf ( NewMes .ge. 10 ) then
	      Write(Temp,1002)NewMes,' new messages.'//CR
	      Call Finger_Out_Routine(Temp(:18))
	    EndIf

c  ! Site-specific note:
c  If you do not wish the mail "From: so-and-so" information printed
c  omit the next section of code.
c	This section contributed by Todd Aven of U. of Mariland
c	Hacked up by yours truly. Rg
c	Now includes Subject [rph] and pretty much a re-hack job
c for v5 [rph] another complete re-hack, the mail file format is similar
c       to vmsmail_profile.data (q.v.)
c
	    MailFile = Mail_Directory(:Btrim(Mail_Directory))//
	1	'MAIL.MAI'

     
	    Open ( Unit=ScratchUnit,
	1	File=MailFile ,
	2	Status='Old' ,
	3	User Open = Priv_UserOpen,
	4	Form='Formatted' ,
	5	Readonly ,
	6	Shared ,
	7	Err=100,
	8	Record Type='Variable',
	9	Organization='Indexed',
	1	Access='Keyed')
     
	    mailrec.rec = ' '

	    jpi_itmlist(1).bufferlen=12
	    jpi_itmlist(1).itemcode=jpi$_username
	    jpi_itmlist(1).bufferaddr=%loc(you)
	    jpi_itmlist(2).endlist=jpi$c_listend
	    call sys$getjpiw(,,,jpi_itmlist,,,)

	    Read(Unit=ScratchUnit,fmt='(a)',IoStat=Status,Err=99,
	1	KeyID=1,Key='NEWMAIL') mailrec.rec

	    foundMail=.false.
	    Do While (status.eq.0)
	      If (len(mailrec.folder).GT.1) then
	        Mail_Time = ' '
	        Mail_day = Day_oftheWeek (mailrec.date)
	        call sys$asctim(,mail_time,mailrec.date)
	        mail_Time = Make_Pretty(Mail_Time)
	        ptr = 91
	        csize=mailrec.rec(ptr:ptr+1)
	        ptr=ptr+2
	        from=mailrec.rec(ptr:ptr+size-1)
	        ptr=ptr+size
		if (index(from,you(:btrim(you))).gt.0) then
		  got_subj=.false.
		  subject=' '
		  fn=0
		  do while ((.not.(got_subj)).or.(fn.eq.5))
		    cfn=mailrec.rec(ptr:ptr+1)
		    cfnlen=mailrec.rec(ptr+2:ptr+3)
		    if (fn.eq.2) then
		      subject=mailrec.rec(ptr+4:ptr+4+fnlen-1)
		      got_subj=.true.
		    end if
		    ptr=ptr+4+fnlen
		  end do 


		  if (.not.foundMail) then
		    Call Finger_Out_Routine(LF//' Has the following '//
	1	      'unread messages from you:'//CR//LF)
		    foundMail = .true.
		  endif
		  Call Finger_Out_Routine(LF//' '//
	1		Mail_Day(:btrim(mail_day))//', '//
	2		Mail_Time//'  Subj: '//
	3		subject(1:jmin0(len(subject),40))//CR)
	     endif
	    endif
		mailrec.rec = ' '
		Read(Unit=ScratchUnit,
	1	IoStat=Status,
	2	fmt='(a)',
	3	End=99) Mailrec.rec
	    If (mailrec.folder(1:7).ne.'NEWMAIL') status = -1 !short cut
	   enddo
     
99	    Continue

	    Call Priv_Close(ScratchUnit)

100	    Continue			!newmes out of sync
c  ! Site-specific - end of message display section
     
	  Else
	    Call Finger_Out_Routine('(no new mail)'//CR)
	  Endif
     
	EndIf
     
C  Plan information
     
c  ! Site-specific note:
c  You may opt for another standard name for the plan file, see above.
	If ( (TestOutput.and.FlagPlan) .ne. 0 ) then
	  Call Finger_Out_Routine(LF//' Plan: ')
	FlgUIC=1
c flag to test stored UIC if present
	  PlanFile = Directory(1:Btrim(Directory))//PlanFileName1
	  Open (	Unit=ScratchUnit,
	1       File=PlanFile,
	2       User Open = Priv_UserOpen,
	2       Status='old',
	3       Err=201,
	4       Shared,
	5       Readonly)
	  GoTo 250
c  Error opening Plan File - look for an alternate.
201       Continue
	FlgUIC=1
	  PlanFile = Directory(1:Btrim(Directory))//PlanFileName2
	  Open (	Unit=ScratchUnit,
	1       File=PlanFile,
	2       User Open = Priv_UserOpen,
	2       Status='old',
	3       Err=202,
	4       Shared,
	5       Readonly)
	  GoTo 250
c  look for another - or give up ! Site-specific
202       Continue
c	 PlanFile = Directory(1:Btrim(Directory))//PlanFileName3
c	 Open (	Unit=ScratchUnit,
c       1       File=PlanFile,
c       2       User Open = Priv_UserOpen,
c       2       Status='old',
c       3       Err=301,
c       4       Shared,
c       5       Readonly)
c	 GoTo 250
	  GoTo 301
c  Found the file - list it.
250       Call Finger_Out_Routine(CR)
	FlgUIC=0
	UserUIC=0
c zero flag and saved UIC value (just in case)
	  DoWhile(.True.)
	    Read(ScratchUnit,2000,End=300) l_line, Line
C ** Site-Specific
C uncomment to enable BYPASS logic
c	      IF(.NOT.FLAG_BYPASS)THEN
c		do ibcz=1,l_line
c		  if(line(ibcz:ibcz).lt.' ')then
c		     iibcz=ichar(line(ibcz:ibcz))
c		     if(iibcz.ne.9.and.iibcz.ne.10
c	1	        .and.iibcz.ne.13)line(ibcz:ibcz)='.'
c		  endif
c		enddo
c	      ENDIF
	    Call Finger_Out_Routine(LF//Line(1:l_line)//CR)
	  EndDo
300       Call Priv_Close(ScratchUnit)
	  Return
C  Here if no plan file
301       Continue
	  Call Finger_Out_Routine('(no plan file)'//CR)
	EndIf
	Return

999	Continue
	Call Priv_Close(UafUnit)
	Return
1000	Format(<UAF$K_Length>A1)
1001    Format(I1,A)
1002    Format(I3,A)
2000    Format(Q,A)
	End

c------------------------------------------------------------------------------
	Character*25	Function Get_Location(Terminal,TTType,PID)
c  This routine returns the location and terminal type, giver the
c  terminal name.  It user the data in the shared common section.
c  ! site-specific
c  If the terminal begins with RT it is considered a DECnet terminal.
c  If it begins with PT is ia assumed to be a pseudoterminal.  We use
c  these to connect to a network called jnet.  These can be ignored
c  if you don't have them, otherwise change appropriately.
c  If the terminal begins with VT its considered a VMS V4.x virtual
c  terminal and the associated physical terminal is used.
c  In the normal situation, the 25 characters returned are
c  the location and 25 for the type.  Obviously these can be 
c  can be shortened for printing (I normally print 15 + 25)
	Include		'FingerCom.For'
c Site-specific
c LAT ident stuff
c [rph] 01-06-88 - Server names and port names can be as large as
c		   16 and 12 characters respectively. By default only
c		   the first 8 characters of each are displayed. This
c		   can easily be changed.
	Include 'fingerdef.inc'
	Include '($DVIDEF)'
	Character Server*16, Port*12, Make_Pretty*70
	Integer  Status
	Integer		Privilege(2) /0,0/
c end LAT ident data
	Character	Terminal*8, TTType*25
	Character	Network*20,	Get_Network*20
	Character	Node*12,	Get_Decnet_Node*6
	Character	Get_jnet_Node*8
	Integer		Btrim,		PID
	Integer		Lib$GetDVI
	External	Lib$GetDVI
	Character	Phy_Terminal*8, TT_AccPorNam*64
	Integer		L_Phy_Terminal, L_TT_AccPorNam, Slash
	Get_Location = ' '	! If location can't be found
	TTType = ' '
c  first see if a VT (virtual terminal) is connected to a physical
c  terminal.
	If ( Terminal(1:2) .eq. 'VT' ) then
	    terminal='_'//terminal
	    Call Lib$GetDVI(DVI$_TT_PhyDevNam,,Terminal,,
     1	      Phy_Terminal,L_Phy_Terminal)
	    If (L_Phy_Terminal.gt.0)
     1	      Terminal = Phy_Terminal(2:L_Phy_Terminal)
	    If (index(terminal,':').eq.0)
     1	      Terminal=Terminal(:Btrim(terminal))//':'
	Endif
	If ( Terminal(1:2) .eq. 'RT' ) Then
	    Node = Get_DECnet_Node(PID)
	    Network = Get_Network('D')
	    If ( Network .eq. '?' ) Network = 'DECnet'
	    Get_Location = Node(:Btrim(Node))//
	1	'.'//Network(:Btrim(Network))
	ElseIf ( Terminal(1:2) .eq. 'PT' ) Then	! Site-specific
	    Node = Get_jnet_Node(Terminal)
	    Network = Get_Network('J')
	    If ( Network .eq. '?' ) Network = 'jnet'
	    Get_Location = Node(:Btrim(Node))//
	1	'.'//Network(:Btrim(Network))
	ElseIf ( Terminal(2:3) .eq. 'VT' ) then
	    Get_Location = '<disconnected>'
	ElseIf ( Terminal(1:2) .eq. 'LT' ) then
	    Get_Location = 'Lat'
c ** Site-Specific
c  get LAT info
c
c  getdvi(tt_accpornam) returns a string in the form server/port or for
c  PSI connections, the originating connection
c
		terminal = '_' // terminal
		status = Lib$GetDVI(DVI$_TT_AccPorNam,,Terminal,,
     1		     TT_AccPorNam,L_TT_AccPorNam)

		terminal = terminal(2:len(terminal))
		slash = index(TT_AccPorNam,'/')
		If (Status) then
		 If (slash.gt.0) then
		  Server = TT_AccPorNam(1:slash-1)
		  Port = TT_AccPorNam(slash+1:slash+9)
		  Server = Make_Pretty(Server)
		  Port = Make_Pretty(Port)
		  Get_Location = Server(1:8) // ' ' // Port(1:8)
		 else	!PSI terminal
		  Get_location = TT_AccPorNam(1:btrim(TT_AccPorNam))
		 endif
		endif
	ElseIf ( Terminal(1:2) .eq. 'PX' ) then
	    Get_Location = 'PC Network'
	Else
c	  search for Terminal in shared common database
	    Do ii = 1,Loc$I_Last
		If ( Loc$C_Terminal(ii) .eq. Terminal ) then
		    Get_Location = Loc$C_Location(ii)
		    TTType = Loc$C_TTType(ii)
		    Return
	    	End if
	    End do
	EndIf
	Return
	End


c-----------------------------------------------------------------------------
	Character*5 Function Get_Idle(PID)

c  Call a kernel mode routine which makes a table of idle times
c  for allocated terminals

	Include		'Fingercom.for'

	Integer		I_Idle, I_hr, I_min
	Integer		PID

	Get_Idle = ' '

	Do ii = 1,max_units
	    If ( TT_UCB$I_PIDs(ii) .eq. 0 ) Return
	    If ( PID .eq. TT_UCB$I_PIDs(ii) ) then
		I_Idle = TT_UCB$I_Times(ii)
		Go to 200
	    End if
	End do
	Return

200	Continue
	If ( I_Idle .le. 0 ) Return
	I_hr = I_Idle/3600
	I_Min = I_Idle/60 - 60*I_hr
	Write (Get_Idle,1000,Err=300) I_hr, I_Min
	If ( I_hr .eq. 0 ) then
	    If ( I_Min .le. 0 ) then
	      Get_Idle = '    .'
	    else
	      Get_Idle(1:3) = ' '
	    end if
	Else
	    If ( Get_Idle(4:4) .eq. ' ' ) Get_Idle(4:4) = '0'
	End if
300	Return

1000	Format(I2,':',I2)

	End

c-----------------------------------------------------------------------------
	Character*6 Function Get_DECnet_Node(PID)

c  Get the remote DECnet node name given a link found in the UCB
c  for the remote terminal.  Taken from Craig Leres (lbl) Ratfor routine.
c  His comments follow.

c	### rmtinfo - get remote terminal info
c	#
c	# synopsis
c	#
c	#    integer status, link, node
c	#    character site(7)
c	#    status = rmtinfo ( link, node, site )
c	#
c	#	link - rtt link number
c	#	node - returned DECnet node number
c	#	site - character string to receive site name
c	#	status - VMS return status
c	#
c	# Given the link number (as found in the ucb$w_rtt_link offset in the
c	# unit control block of a remote terminal), this routine consults NETACP
c	# to get the node number and site name of the DECnet host the remote
c	# terminal is attached to. The privilege NETMBX is required for use.
c	#
c	# Warning: This routine is chalked full of undocumented MAGIC.
c	#

	Include		'Fingercom.for'

	Parameter NFB$C_FC_SHOW = '00000022'X
	Parameter NFB$M_NOUPD	= '00000004'X
	Parameter NFB$C_DB_LLI	= '00000008'X
	Parameter NFB$C_OP_EQL	= '00000000'X
	Parameter NFB$C_LLI_LLN	= '08010012'X
	Parameter NFB$C_WILDCARD= '00000001'X
	Parameter NFB$C_LLI_PNA	= '08010014'X
	Parameter NFB$C_LLI_PNN	= '08020043'X
	Parameter NFB$C_ENDOFLIST= '00000000'X

	Parameter NFB_SIZE	= 28	!	# one gronk + 3 long
	Parameter BUF_SIZE	= 12	!	# long + word + 6 byte string
	Parameter SITE_SIZE	= 6	!	# number of characters in a hostname

	Integer		PID

	Integer i, status, chan, sys$assign, sys$qiow, enode
	integer net_dsc(2), nfb_dsc(2), key_dsc(2), key(2), buf_dsc(2)
	Character Net_str*4 /'NET:'/
	integer k1, k2, f1, f2, f3
	integer*2 c1, c2, iosb(4), elen
	logical init/.false./
	byte nfb(NFB_SIZE), buf(BUF_SIZE), esite(SITE_SIZE)
	equivalence (nfb(5), k1), (nfb(9), k2), (nfb(13), c1), (nfb(15), c2)
	equivalence (nfb(17), f1), (nfb(21), f2), (nfb(25), f3)
	equivalence (buf(1), enode), (buf(5), elen), (buf(7), esite)
	external ss$_normal, io$_acpcontrol

	Get_DECnet_Node = ' '
	Do ii = 1, SITE_SIZE
	    esite(ii) = ' '
	End do
	Do ii = 1,max_units
	    If ( TT_UCB$I_PIDs(ii) .eq. 0 ) Return
	    If ( PID .eq. TT_UCB$I_PIDs(ii) ) then
		link = TT_UCB$I_RTT_Link(ii)
		Go to 200
	    End if
	End do
	Return
200	Continue

	Net_dsc(1) = len(Net_Str)
	Net_dsc(2) = %loc(Net_Str)
	status = sys$assign ( Net_dsc, chan, , )
	if ( status .ne. %loc(ss$_normal) ) then
	    Call Lib$Signal(%Val(status))
	    Return
	End if

	nfb(1) = NFB$C_FC_SHOW
	nfb(2) = NFB$M_NOUPD	!	# don't update the database
	nfb(3) = NFB$C_DB_LLI	!	# logical link information database
	nfb(4) = NFB$C_OP_EQL	!	# match the key exactly
	k1 = NFB$C_LLI_LLN	!	# the key is a logical link number
	k2 = NFB$C_WILDCARD	!	# search the whole database
	c1 = 0			!	# must be zero
	c2 = 0			!	# let counted strings vary in length
	f1 = NFB$C_LLI_PNA	!	# partner's node address
	f2 = NFB$C_LLI_PNN	!	# partner's node name
	f3 = NFB$C_ENDOFLIST

	nfb_dsc(1) = NFB_SIZE
	nfb_dsc(2) = %loc(nfb)

	key_dsc(1) = 8
	key_dsc(2) = %loc(key)
	key(1) = 0
	key(2) = link

	buf_dsc(1) = BUF_SIZE
	buf_dsc(2) = %loc(buf)

	status = sys$qiow (,%val(chan),%val(%loc(io$_acpcontrol)),iosb,,,
	1    nfb_dsc,key_dsc,,buf_dsc,,)
	if ( status .ne. %loc(ss$_normal) ) then
	    Call Lib$Signal(%Val(status))
	    Call sys$dassgn (%Val(chan))
	    Return
	End if
	if ( iosb(1) .ne. %loc(ss$_normal) ) then
	    Call Lib$Signal(%Val(iosb(1)))
	    Call sys$dassgn (%Val(chan))
	    Return
	End if
	node = enode
	Do i = 1, SITE_SIZE
	    Get_DECnet_Node(i:i) = Char(esite(i))
	End do

	Call sys$dassgn (%Val(chan))
	return

	end

c-----------------------------------------------------------------------------
	Subroutine Get_Idle_Times

!
! No op this until MP spin locks work
!



c  Call a kernel mode routine which makes a table of idle times,
c  and links from the UCB for finding the DECnet node name,
c  and PIDs for allocated terminals

	Include		'Fingercom.for'
	Include		'Fingerdef.inc'

	Integer		TT_UCB
	Integer		Privilege(2) /0,0/

c  Turn on CMKRNL privileg
!	Privilege(1) =  Prv$M_Cmkrnl
!	Call Sys$Setprv(%Val(1),Privilege,,)
c  Call Kernel mode routine
!	IStatus = TT_UCB(TT_UCB$I_Times,TT_UCB$I_PIDs,TT_UCB$I_Device,
!	1		TT_UCB$I_Unit,TT_UCB$I_RTT_Link,max_units)
c  Turn off CMKRNL privilege
!	Call Sys$Setprv(,Privilege,,)

!	If ( .not. IStatus ) Call Lib$Signal(IStatus)


	Return

	End

c-----------------------------------------------------------------------------
	Character*8	Function Get_jnet_Node(Terminal)

c	This routine finds the jnet node name using a /SYSTEM
c	Logical name of the form JNET_PTYxxxx

	Integer		TRN$_String /Z00000002/
	Integer		TRN_ItemList(4)
	Integer*2	TRN_ItemList2(8)
	Equivalence	(TRN_ItemList,TRN_ItemList2)

	Character	Terminal*8

	Get_jnet_Node = '?'	! default
	If ( Index(Terminal,'PT') .eq. 0 ) Return	! Wrong terminal type
	ii = Index(Terminal,':') - 1

	TRN_ItemList2(1) = 8
	TRN_ItemList2(2) = TRN$_String
	TRN_ItemList(2) = %Loc(Get_jnet_Node)
	TRN_ItemList(3) = %Loc(L_node)
	TRN_ItemList2(7) = 0
	TRN_ItemList2(8) = 0

	SS$_Status = Sys$TrnLnm(,'LNM$SYSTEM_TABLE',
	1	'JNET_'//Terminal(:ii),,
	3	TRN_ItemList)

	Return
	End	
c---------------------------------------------------------------------------
	Character*9	Function Get_Image(Input_PID,LOGINTIM,CPUTIM)

c  This routine does an additional GETJPI to get the image name, the Login
c  time, and the CPU time.  This is not done in the main loop in Local_Finger 
c  because this Getjpi may take a long time for low priority or swapped out
c  processes and these processes are typically not listed by finger anyway.  

c  ! Site-specific note: Only images from "public" directories are identified 
c  by finger for reasons of privacy (basically so "Joe" won't complain that
c  "Harry" is running Adventure all day.)  The several site-specific public 
c  directories are set as parameters here and should be changed for your site.
c  You could also, for example, just check the disk and decide all images on
c  a certain disk are public etc.  Or just eliminate the check altogether 
c  and all images, public or private, will be identified.
c					- Rg
c	Parameter	PublicDirectory1 = 'SYS$SYSROOT:[SYSEXE]'! obviously.
c	Parameter	PublicDirectory2 = 'SYS$UTILITIES:'! These 2 for..
c	Parameter	PublicDirectory3 = 'SYS$SYSUTL:[VPW]'	! my site -Rg
c	Parameter	PublicDirectory4 = 'DUA0:'		! an example
c	Parameter	PublicDirectory5 = 'DRA1:[LOCAL]'	! an example
c
c  ! Site-specific: end of note

	Integer		Input_PID

C  Include all GETJPI data and definitions
	Include		'GETJPIDEF.FOR'
	integer		sys$getjpiw

	Get_Image = '<unavail>'

C  Set up item list for GETJPI
	I = 1
	II = 1
	ITEM_LIST2(II+IC) =	JPI$_IMAGNAME
	ITEM_LIST2(II+BL) =	L_IMAGNAME
	ITEM_LIST(I+BA)  =	%LOC(IMAGNAME)
	ITEM_LIST(I+RL)  =	%LOC(RL_IMAGNAME)
	I = I + 3
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_LOGINTIM
	ITEM_LIST2(II+BL) =	L_LOGINTIM
	ITEM_LIST(I+BA)  =	%LOC(LOGINTIM)
	ITEM_LIST(I+RL)  =	%LOC(RL_LOGINTIM)
	I = I + 3
	II = II + 6
	ITEM_LIST2(II+IC) =	JPI$_CPUTIM
	ITEM_LIST2(II+BL) =	L_CPUTIM
	ITEM_LIST(I+BA)  =	%LOC(CPUTIM)
	ITEM_LIST(I+RL)  =	%LOC(RL_CPUTIM)

	ITEM_LIST(I+3) = 0		! End of list


c  Do Getjpi
	IStatus =  Sys$Getjpiw(,Input_PID,,Item_List,,,)
	If ( .not. IStatus ) Return

c  Check for no image (DCL)
	If ( Imagname(:Rl_Imagname) .eq. ' ' ) Then
	    Get_Image = '$'	! DCL
	    Return
	EndIf

c  Check for public directory
c  ! Site-specific: If you want all images printed, delete this whole block.
c	i_Dir1 = Index(Imagname,PublicDirectory1)	!
c	i_Dir2 = Index(Imagname,PublicDirectory2)	! to be set
c	i_Dir3 = Index(Imagname,PublicDirectory3)	! above for
cc	i_Dir4 = Index(Imagname,PublicDirectory4)	! each site. 
cc	i_Dir5 = Index(Imagname,PublicDirectory5)	! 
c	If ( 
c	1		i_Dir1 .eq. 0 	! one of 
c	2	.and. 	i_Dir2 .eq. 0 	! these for 
c	3	.and. 	i_Dir3 .eq. 0 	! each public 
cc	4	.and. 	i_Dir4 .eq. 0 	! directory
cc	5	.and. 	i_Dir5 .eq. 0 	! at your site.
c	6   ) Then
c	    Get_Image = '<user>' ! default for image in private directory
c	    Return		 ! (for privacy)
c	EndIf
c  ! Site-specific - end of block

c  Image good.  Just get file name.

	Do i = Rl_Imagname,0,-1
	    If ( Imagname(i:i) .eq. ']' ) Goto 101
	    If ( Imagname(i:i) .eq. '>' ) Goto 101
	    If ( Imagname(i:i) .eq. ':' ) Goto 101
	End do

101	ii = i + 1
	iii = Index(Imagname(ii:Rl_Imagname),'.') + ii - 2
	Get_Image = Imagname(ii:iii)

	Return
	End

c---------------------------------------------------------------------------
	Character*25	Function Get_PersonalName(Username)

	Include		'FingerCom.For'

	Character*12	UserName		! User's login name
	Character*25	Owner, Fix_Name*25

	Call NULToSP(Username,12)

c  search for Userame in shared common database
	Do ii = 1,Usr$I_Last
	    If ( Usr$C_Username(ii) .eq. Username ) then
		Owner = Usr$C_PersonalName(ii)
		Go to 122
	    End if
	End do
	Get_PersonalName = ' '	!default if name not found
	Return

122	Continue
	Get_PersonalName = Fix_Name(Owner)

	Return
	End

c---------------------------------------------------------------------------
	Character*12	Function Get_Username(PersonalName,
	1			NMatches,OutFlag,Out_Routine)
c
c  This routine searches the username <--> Personalname database
c  for a match in part (or all) with the personal name and returns
c  the Username.  If there is more than 1 match the last match is
c  returned.  "minimum_match_length" requires at least that many
c  characters for the compare (to avoid matching all kinds of small
c  strings).  The routine also returns the number of matches and will
c  output the match on option.
c
c Note: If "minimum match" is omitted, Finger can be easily used to
c obtain lists of users at a site by searching for all names containing
c a few common letter combinarions (e.g., vowels). The minimum match
c effectively prevents this.
c
c  ! site-specific:	set minimum match length or omit. (see below)
	Parameter	minimum_match_length = 3

	Include		'FingerCom.For'

	Integer		NMatches, Btrim
	Logical		OutFlag, ExactMatch, Match
	Logical		Wild, Wild_Match
	External	Out_Routine
	Character	C_Temp*25, Str$UpCase*25
	Character	Fix_Name*25, Make_Pretty*25
	Character*(*)	PersonalName
	Character*1	LF/10/, CR/13/

	Get_Username = ' '
	NMatches = 0
c  ! site-specific: use following code for minimum match length
	If ( Len(PersonalName) .lt. minimum_match_length ) then
	    ExactMatch = .true.
	Else
	    ExactMatch = .false.
	End if
c  check if wildcards (a bit useless considering...)
	If ((Index(PersonalName,'*') + Index(PersonalName,'%')).gt.0)
	1	Wild = .true.
c  search for PersonalName in shared common database
	Do ii = 1,Usr$I_Last
	    Match = .false.
	    If ( ExactMatch ) then
		If ( Str$UpCase(Usr$C_Personalname(ii))
	1		 .eq. Personalname ) Match = .true.
	    Else if ( Wild ) then
		iii = Btrim(Usr$C_Personalname(ii))
		C_Temp = Str$Upcase(Usr$C_Personalname(ii))
		Match = Wild_Match('*'//PersonalName//'*',	! add wild
	1		C_Temp(:iii))				! front & back
	    Else
		If ( Index(Str$UpCase(Usr$C_PersonalName(ii)),
	1	    PersonalName) .ne. 0 ) Match = .true.
	    End if
	    If ( Match ) then
		NMatches = NMatches + 1
		Get_Username = Usr$C_Username(ii)
		If ( OutFlag ) then
		    Call Out_Routine(LF//Usr$C_Username(ii)//' - '//
	1		Make_Pretty(Fix_Name(Usr$C_PersonalName(ii)))
	2		//CR)
		End if
	    End if
	End do

	Return
	End

c---------------------------------------------------------------------------
	Character*9	Function Day_OfTheWeek(BinTime)

	Character*9	Day(7) /
	1		'Monday',
	2		'Tuesday',
	3		'Wednesday',
	4		'Thursday',
	5		'Friday',
	6		'Saturday',
	7		'Sunday'/

	Integer		BinTime(2), DayNumber

	Call Lib$Day_of_Week(BinTime,DayNumber)
	Day_OfTheWeek = Day(DayNumber)

	Return
	End

c---------------------------------------------------------------------------
	Subroutine	NULToSP(String,Length)

	Character	String*(*)
	Character	NUL/0/, SP/' '/

	Do ii=1,Length
	    If ( String(ii:ii) .eq. NUL ) String(ii:ii) = SP
	EndDo

	Return
	End

c------------------------------------------------------------------------
	Character*25 Function Fix_Name(Name)

	Character	Name*25, First_Name*25, Last_Name*25
	Character	SP /' '/

	Fix_Name = Name
	If ( Name .eq. ' ' ) Return

	If ( Name(1:1) .eq. '(' ) GoTo 200
	i_Comma = Index(Name,',')
	If ( i_Comma .eq. 0 ) GoTo 200

	i_Last = i_Comma-1
	If ( i_Last .le. 0 ) Then
	    Last_Name = ' '
	    i_Last = 1
	EndIf
	Last_Name = Name(:i_Last)

	First_Name = Name(i_Comma+1:)
	i_First = 25 - i_Comma
	Do ii=i_First,2,-1
	    If ( First_Name(ii:ii) .ne. SP ) GoTo 110
	EndDo

110	i_First = ii
	Do ii = 1,i_First
	    If ( First_Name(ii:ii) .ne. SP ) GoTo 120
	EndDo

120	First_Name = First_Name(ii:i_First)
	i_First = i_First - ii + 1

	Fix_Name = First_name(:i_First)//SP//Last_name(:i_Last)

200	Return

	END


c------------------------------------------------------------
	Character*(*) Function Make_Pretty(String)

c	! Site-specific note
c  This implements one person's idea of what constitutes "pretty"
c  text: all words capitalized, with other letters lower case.  If
c  you like all UPPER-CASE (like VMS) or all lower-case (like unix)
c  feel free to change this as per comments below.		- Rg

	Character*(*)	String
	Character	Item
	Character	Down_Case, Str$UpCase	! May have to specify length
	Logical		NewWord, Alpha

	NewWord = .true.
	Make_Pretty = ' '

	Do i = 1, Len(String)
	    Item = String(i:i)
	    Alpha = (Item .ge. 'A' .and. Item .le. 'Z') .or.
	1	    (Item .ge. 'a' .and. Item .le. 'z')
	    Item = Down_Case(Item)
	    If ( NewWord ) Item = Str$UpCase(Item)
	    NewWord = .not. Alpha
	    Make_Pretty(i:i) = Item
	EndDo

c  Following are alternate possibilities.	! Site-specific
c  Must give "Down_Case" and "Str$UpCase" correct length specification above.
c	Make_Pretty = Down_Case(String)		! For all lower case
c	Make_Pretty = Str$UpCase(String)	! For all UPPER CASE

	Return
	End

c------------------------------------------------------------
	Character*(*) Function Filter_Control_Chars(String)

c	This routine can be used to filter control characters
c	from the output stream and put a period (".") in their
c	place to prevent wierd process names etc. from messing 
c	up the terminal screen.

	Character*(*)	String

	Character*256	FilterTable 

	    Parameter ( FilterTable =
	1	'................................' //
	2	' !"#$%&''()*+,-./0123456789:;<=>?'//
	3	'@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_' //
	4	'`abcdefghijklmnopqrstuvwxyz{|}~.' //
	5	'................................' //
	6	'................................' //
	7	'................................' //
	8	'................................' )

	Call Lib$Movtc(String,' ',FilterTable,Filter_Control_Chars)

	Return
	End

c------------------------------------------------------------
	Character*(*) Function Down_Case(Item)

	Character*(*)	Item

	Do i = 1,Len(Item)
	    Down_Case(i:i) = Item(i:i)
	    If ( Item(i:i) .ge. 'A' .and. Item(i:i) .le. 'Z' ) 
	1	Down_case(i:i) = Char(Ichar(Item(i:i)) + 32)
	EndDo

	Return
	End

c------------------------------------------------------------
	Integer Function OutLink_UserOpen(FAB,RAB,Unit)

	Integer		FAB(30), RAB(30)
	Integer		Rab$L_Rop/2/, Rab$M_Loc/Z00010000/
	Integer		Sys$Create, Sys$Connect
	Integer		Unit, OutLinkOpenStatus, OutLinkRMSStatus

	Common	/OutLinkOpen_Common/ OutLinkOpenStatus, OutLinkRMSStatus

	iii = Sys$Create(FAB)
	OutLinkRMSStatus = iii		! RMS Status
	OutLinkOpenStatus = FAB(4)	! This is the Fab$l_STS field: status

	If ( .not. iii ) Then
	    IF ( OutLinkOpenStatus .eq. 0 ) OutLinkOpenStatus = iii
	    OutLink_UserOpen = iii
	    Return
	EndIf

	RAB(Rab$L_Rop) = RAB(Rab$L_Rop) .or. Rab$M_Loc	! Locate option
	OutLink_UserOpen = Sys$Connect(RAB)

	Return
	End

c--------------------------------------------------------------------------
	integer function btrim (string)

c   Integer function to determine the length of a character string with
c   trailing blanks and tabs removed.
c   Routine written at CMU PSYA::

	implicit integer*4 (a-z)
	integer countr
	character*(*) string
	character*1 tab, NUL, space
	
	NUL = char(0)
	tab = char(9)
	space = char(32)

	do 10 countr = len (string), 1, -1
		if (string (countr : countr) .ne. NUL .and.
     *			string (countr:countr) .ne. space .and.
     *			string (countr:countr) .ne. tab) then
			btrim = countr
			return
		endif
10	continue

	btrim = 1
	return
	end


c------------------------------------------------------------
	Integer Function Priv_UserOpen(FAB,RAB,Unit)

c  open a system file with privilege.

c  set bits in the FAB to require EXEC mode logical name
c  translation to be used when opening the file and turn
c  SYSPRV on for the open.

	Include		'Fingerdef.inc'
	Include '($RMSDEF)/nolist'
	Include '($SYSSRVNAM)/nolist'
	Include '($FABDEF)/nolist'
	Include '($RABDEF)/nolist'
	Include '($xabDEF)'
	Include	'($XABPRODEF)'
	Record /FABDEF/Fab, /RABDEF/ rab
	Record /XABPRODEF1/ xabpro
	Integer*4 LUIC
	Common /xab_uic/ LUIC
	External XABSET, XABGET
	Integer		Privilege(2) /0,0/
c	Byte		FAB$B(0:119)
c	Integer		RAB(30)
c	Integer*4	Sys$Open, Sys$Connect		![rph] 01-06-88
	Integer		Unit
	Integer*4       UserUIC,FlgUIC,ownUIC
	Common/UseUIC/UserUIC,FlgUIC

c  set Logical name access to EXEC mode
	FAB.FAB$B_ACMODES = FAB.FAB$B_ACMODES .or.
     1   1
c	1	( (1) * 2**FAB$V_LNM_MODE)		! require EXEC mode
c  fab$V_lnm_mode = 0 so omit ref since define includes double def it
c set up xab
	If (FlgUIC .ne. 0 ) then
	Call XABSET( %VAL (fab.FAB$L_XAB))
	EndIf

c  Turn on SYSPRV privilege
	Privilege(1) =  Prv$M_Sysprv
	Call Sys$Setprv(%Val(1),Privilege,,)

c  open file
	iii = Sys$Open(FAB)
	If (FlgUIC .ne. 0) then
	If (iii .eq. rms$_NORMAL) then
	  iii= SYS$DISPLAY(fab)
	  Call XABGET (%VAL ( fab.FAB$L_XAB))
	  OwnUIC=LUIC
d	Write(6,4555)userUIC, ownUIC
d4555	Format(' user UIC=', i12,' FileOwner UIC=',i12)
	  if (ownUIC.ne.userUIC) then
		iii=sys$close(FAB)
	  End IF
	End if
	End If
c  Turn off SYSPRV privilege
	Call Sys$Setprv(,Privilege,,)
	If (FlgUIC .ne.0) then
	FlgUIC=0
c If flagged for nonzero UIC check, compare file owner UIC
c here with userUIC longword and if non equal close the file
c and forget it. One pass, to avoid possible problems, since
c this is only for FINGER.PLN files.
c need $xabpro to get UIC.
	  if (ownUIC.ne.userUIC) then
		iii= sys$open(FAB)
c try nonpriv'd open if wrong UIC, in case file IS world readable
c but owned by, e.g., some identifier on behalf of the user we're
c fingering.
	  endif
	EndIF

	If ( .not. iii ) Then
	    Priv_UserOpen = iii
	    Return
	EndIf

c  connect
	Priv_UserOpen = Sys$Connect(RAB)

	Return
	End

c------------------------------------------------------------
	Integer Function Priv_Close(Unit)

c  Close a system file with privilege.  Needed for Files opened with
c  privilege in VMS V4.2 (it is rumored)

	Include		'Fingerdef.inc'
	Integer		Privilege(2) /0,0/
	Integer		Unit

c  Turn on SYSPRV privilege
	Privilege(1) =  Prv$M_Sysprv
	Call Sys$Setprv(%Val(1),Privilege,,)

c  Close file
	Close( Unit = Unit )

c  Turn off SYSPRV privilege
	Call Sys$Setprv(,Privilege,,)

	Return
	End

c-------------------------------------------------------------
	Integer*2 Function Get_w_Val(I2)

	Integer*2	I2

	Get_w_Val = I2

	Return

	End

c-----------------------------------------------------------------------------
	Subroutine Make_Info(PID,STS,Prcnam,Username,Terminal,
	1	State, PgCnt, HeaderWritten, TestOutput, FlagProcess)

c  This routine and subroutine Show_Info are used together to provide
c  a sorted output display.  If the command option SORT is turned on,
c  user information is written into an array in this subroutine.  Then,
c  the array is sorted, and written to the output.
c
c  Added by  Art Greenberg, RCA Laboratories

	Include		'GETJPIDEF'
	Include		'FingerFlg'
	Include		'Fingerdef.inc'

	Integer		PID_array, STS_array, State_array,
	1		PgCnt_array, HeaderWritten, TestOutput,
	2		FlagProcess, FP_array

	Character	Prcnam_array*15, Username_array*12,
	1		Terminal_array*8

	Dimension	PID_array(200), STS_array(200),
	1		State_array(200), PgCnt_array(200),
	2		Prcnam_array(200), Username_array(200),
	3		Terminal_array(200), FP_array(200)

	Common	/Info/	PID_array, STS_array, State_array,
	1		PgCnt_array, Prcnam_array, Username_array,
	2		Terminal_array, Last_Number, FP_array

	Integer		PgCnt
	Integer		Index

	Data		Index /0/

c  Initialize the info array if first time thru here.

	If (Index .eq. 0) then
	    Index = 1
	EndIf

c  Enter one user's information into the info arrays.

	PID_array(Index)	= PID
	STS_array(Index)	= STS
	Prcnam_array(Index)	= Prcnam
	Username_array(Index)	= Username
	Terminal_array(Index)	= Terminal
	State_array(Index)	= State
	PgCnt_array(Index)	= PgCnt
	FP_array(index)		= FlagProcess

	Last_Number		= Index
	Index			= Index + 1

c  Done!

	Return

	End



c------------------------------------------------------------------
	Subroutine Show_Info (HeaderWritten, Finger_Out_Routine,
	1                     TestOutput)

c  This routine sorts the user info array, and outputs it.

	Include		'GETJPIDEF'
	Include		'FingerFlg'
	Include		'Fingerdef.inc'

	External	Finger_Out_Routine

	Integer		PID_array, STS_array, State_array,
	1		PgCnt_array, FP_array

	Character	Prcnam_array*15, Username_array*12,
	1		Terminal_array*8

	Dimension	PID_array(200), STS_array(200),
	1		State_array(200), PgCnt_array(200),
	2		Prcnam_array(200), Username_array(200),
	3		Terminal_array(200), FP_array(200)

	Common	/Info/	PID_array, STS_array, State_array,
	1		PgCnt_array, Prcnam_array, Username_array,
	2		Terminal_array, Last_Number, FP_array

	Character*9	Get_Image, Image_Name
	Character*11	Login_Time
	Character*20	Get_LastName, LastName, LN_array, SortType
	Logical		HeaderWritten, Swapped
	Integer		TestOutput,	FlagProcess
	Integer		Index, Index_array, Temp, SortField
	Dimension	Index_array(200), LN_array(200)
	Common /Sorter/	SortType, SortField

c  Sorting is done by a bubble sort (yeah, I know .... yech! ... but it
c  was easy!).  To have reasonable performance, an array of indecies
c  is initialized in sequence, and then the indecies are swapped around
c  as the sort proceeds.  Then, that array is used to select the user
c  info in the sorted order.

c  Initialize the index array, and get the sort information too.
c  [rph] this whole if-then-else used to be INSIDE the DoWhile. I
c  hoisted it to prevent situations in which if you were sorting on
c  field 5 you'd end up with 5*Last_number extra compares.

	Index = 1
	If (SortField .eq. 0) then
	  DoWhile(Index .le. Last_Number)
	    Index_array(Index) = Index
	    LN_array(Index) = ' '			!20 spaces
	    LN_array(Index) = Get_LastName(Username_array(Index))
	    Index = Index + 1
	  EndDo
	Else If (SortField .eq. 1) then
	  DoWhile(Index .le. Last_Number)
	    Index_array(Index) = Index
	    LN_array(Index) = ' '			!20 spaces
	    LN_array(Index) = Username_array(Index)
	    Index = Index + 1
	  EndDo
	Else If (SortField .eq. 2) then
	  DoWhile(Index .le. Last_Number)
	    Index_array(Index) = Index
	    LN_array(Index) = ' '			!20 spaces
	    LN_array(Index) = Prcnam_array(Index)
	    Index = Index + 1
	  EndDo
	Else If (SortField .eq. 3) then
	  DoWhile(Index .le. Last_Number)
	    Index_array(Index) = Index
	    LN_array(Index) = ' '			!20 spaces
	    Write(LN_array(Index), 1001) PID_array(Index)
	    Index = Index + 1
	  EndDo
	Else If (SortField .eq. 4) then
	  DoWhile(Index .le. Last_Number)
	    Index_array(Index) = Index
	    LN_array(Index) = ' '			!20 spaces
	    LN_array(Index) = Terminal_array(Index)
	    Index = Index + 1
	  EndDo
	Else If (SortField .ge. 5) then
	  DoWhile(Index .le. Last_Number)
	    Index_array(Index) = Index
	    LN_array(Index) = ' '			!20 spaces
	    Image_Name = Get_Image(PID_array(Index),LOGINTIM,CPUTIM)
	    If (SortField .eq. 5) Then
	      Call Sys$AscTim(,Login_Time,LOGINTIM,%val(1))
	      LN_array(Index) = Login_Time(1:5)
	    Else
	      LN_array(Index) = Image_Name
	    EndIf
	    Index = Index + 1
	  EndDo
	EndIf
	Swapped = .true.

c  Sort by the extracted data.

	DoWhile ( Swapped )
	    Index = 1
	    Swapped = .false.
	    DoWhile (Index .lt. Last_Number)
	        If ( LGT ( LN_array(Index_array(Index  )),
	1                  LN_array(Index_array(Index+1)) ) ) then
	            Temp = Index_array(Index)
	            Index_array(Index) = Index_array(Index + 1)
	            Index_array(Index + 1) = Temp
	            Swapped = .true.
	        EndIf
	        Index = Index + 1
	    EndDo
	EndDo

c  Send the sorted data to the output.

	Index = 1
	DoWhile (Index .le. Last_Number)
	    Call User_Info(PID_array(Index_array(Index)),
	1                  STS_array(Index_array(Index)),
	2                  Prcnam_array(Index_array(Index)),
	3                  Username_array(Index_array(Index)),
	4                  Terminal_array(Index_array(Index)),
	5                  State_array(Index_array(Index)),
	6                  PgCnt_array(Index_array(Index)),
	7                  HeaderWritten,
	8                  TestOutput,
	9                  FP_array(Index_array(Index)),
	9                  Finger_Out_Routine)
	    Index = Index + 1
	EndDo


	Return

1001	Format(Z8)

	End


c------------------------------------------------------------------
	Character*20	Function Get_LastName(Username)

	Include		'GETJPIDEF'
	Include		'FingerFlg'
	Include		'Fingerdef.inc'

	Logical		IsPrint

	Character	ToUpper
	Character*20	Get_PersonalName, PersonalName, LastName
	Integer		Length, Pointer, Btrim, Index, End

	PersonalName	= Get_PersonalName(Username)
	Length		= Btrim(PersonalName)

c  Have to make sure the name is uppercase for sorting purposes.

	Index = 1
	DoWhile (Index .le. Length)
	    PersonalName(Index:Index) = ToUpper(PersonalName(Index:Index))
	    Index = Index + 1
	EndDo

c  Scan backward from the end of the name string to isolate the last
c  name.

	Pointer = Length
	DoWhile ( IsPrint(PersonalName(Pointer:Pointer)) .and.
	1        (Pointer .gt. 0) )
	    Pointer = Pointer - 1
	EndDo
	Pointer = Pointer + 1

c  Copy the last name into the returned string.

	LastName = ' '			! 20 spaces
	Index = 1
	End = Length - Pointer + 1
	DoWhile (Index .le. End)
	    Position = Index + Pointer - 1
	    LastName(Index:Index) = PersonalName(Position:Position)
	    Index = Index + 1
	EndDo

c  Now concat the balance of the personal name to the last name.  This
c  will cause sorting to reconcile people with the same last name.

	If (Pointer .gt. 1) then
	    Get_LastName = LastName(:End) // PersonalName(1:Pointer-1)
	Else
	    Get_LastName = LastName(:End)
	EndIf

	Return

	End



c-------------------------------------------------------------
	Integer Function Get_l_Val(I)

	Integer	I

	Get_l_Val = I

	Return

	End

c------------------------------------------------------------------
	Logical		Function IsPrint(Candidate)

	Character	Str$UpCase, Candidate, Temp

	Temp = Str$UpCase (Candidate)

	If ( (Temp .gt. ' ') .and. (Temp .lt. 'a') ) then
	    IsPrint = .true.
	Else
	    IsPrint = .false.
	EndIf

	Return

	End


c------------------------------------------------------------------
	Character	Function ToUpper (Candidate)

	Character	Candidate
	Character*26	UCase_Alphas, LCase_Alphas
	Integer		Place

	Data		UCase_Alphas /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
	Data		LCase_Alphas /'abcdefghijklmnopqrstuvwxyz'/

	Place = Index(LCase_Alphas, Candidate)
	If (Place .ne. 0) then
	    ToUpper = UCase_Alphas(Place:Place)
	Else
	    ToUpper = Candidate
	EndIf

	Return

	End


c------------------------------------------------------------------
	SUBROUTINE XABSET ( xabpro )
C
	INCLUDE '($XABPRODEF)'
C
	RECORD	/XABPRODEF1/ xabpro
C
	INTEGER*4	l_uic
C
	COMMON	/XAB_UIC/   l_uic
C
	xabpro.XABPRODEF$$_FILL_1 = XAB$C_PRO	    ! Type of XAB block.
	xabpro.XABPRODEF$$_FILL_2 = XAB$C_PROLEN    ! Length of PRO XAB.
C	xabpro.XABPRODEF$$_FILL_4 = 0		    ! Next XAB address.
	RETURN
	END
C
	SUBROUTINE XABGET ( xabpro )
C
	INCLUDE '($XABPRODEF)'
C
	RECORD	/XABPRODEF1/ xabpro
C
	INTEGER*4	l_uic
C
	COMMON	/XAB_UIC/   l_uic
C
	l_uic = xabpro.XAB$L_UIC
	RETURN
	END


c------------------------------------------------------------------
c	Update history / implementation notes -
c
C	V1.00	Base version Working with DEC-20	June 1982
C	V1.01	Index of nodes with routing		June 1982
C	V1.02	Return open error message on failure
C		to establish link to next node		July 1982
C	V1.03	Slight change in task spec for VMS V3.0	July 1982
C	V1.04	Add image name information		July 1982
C
C	V2.00	Start looking for individuals		July 1982
C	V2.01	Clean up IO units			July 1982
C	V2.02	Clean up LOCATION, NAME & IMAGE		July 1982
C	V2.03	Fix individual finger w. wildcards	Aug. 1982
C	V2.04	Put GETJPI stuff in include file	Aug. 1982
C
C	V3.00	Combine local and network invocation	Aug. 1982
C	V3.01	Consolidate IO units into COMMON	Aug. 1982
C	unspec	Added terminal display -- PSYA::LUCAS	Sep. 1982
C	V3.02	Added typing of <username>.PLN files	
C		when fingering a specific user, as well
C		as telling if user has any new mail
C		messages. -- PSYA::OHLUND		Sep. 1982
C	V3.03	Change <username>.PLN to FINGER.PLN Rg	Sep. 1982
C	V3.04	Fix a few bugs. Rg			Sep. 1982
C	V3.10	Get personal name from UAF		Nov. 1982
C	V3.20	Get load averages			Nov. 1982
C	V3.25	Get node name from SYS$NODE		Nov. 1982
C	V3.30	Get current Mail messages		Nov. 1982
C	V3.35	Get day of the week			Nov. 1982
C	V4.00	Complete cleanup and rationalization		15-Nov-1982
c	V4.01	Fix bug in Get_Image scanning for image name	16-Nov-1982
c	V4.02	"Make_Pretty" the image name. Put all "Make_Pretty"'s
c		in Output routines.				18-Nov-1982
c	V4.03	Remove all Str$UpCase calls but the 1st
c		in routine Finger and in Make_Pretty.		18-Nov-1982
c	V4.04	Make load device a parameter			22-Nov-1982
c	V4.05	Fix mail-messages > 99 bug.			23-Nov-1982
c	V4.06	Put in handler to catch signalled errors
c		and route messages back to requesting node	17-Dec-1982
c	V4.07	Fix bug in MailTextInfo "From:" message.	 6-Jan-1983
c	V4.08	Slight mod in load average output statement.	17-Mar-1983
c	V4.09	Put in BITnet for location for PTys		24-Apr-1983
c
c	V5.00	Restructure program to use callable output
c		routine.  This is in anticipation of other
c		network support.				19-May-1983
c	V5.01	Allow terminal names to 6 char (7 including the
c		":"). This allows 3 digit numbers, e.g. TTC123	19-May-1983
c	V5.02	Put in limits to the number of messages output
c		by the signal_handlers to catch runaway error
c		loops						19-May-1983
c	V5.03	Add CPU type and VMS version to header.		20-May-1983
c	V5.04	Add display qualifiers to .CLD file		4-Jun-1983
c		In anticipation of having all display options
c		selectable by the user.
c	V5.05	add "no such jobs." message.			4-Jun-1983
c	V5.06	Change Flag integers to parameters		6-Jun-1983
c	V5.06	Check for NET, SUBPROCESS, and SYSTEM jobs	6-Jun-1983
c	V5.07	Move flag definitions to include file.		7-Jun-1983
c	V5.08	Fix wrong mask PCB$M_NETWRK			9-Jun-1983
c	V5.09	Change OPEN statement for load average due
c		to aparent VMS change in V3.2			18-Aug-1983
c	V5.10	Use Fortran IO instead of LIB$PUT_SCREEN locally
c		to avoid screw ups on hard copy devices. Consolidate
c		DECnet and local output routine: RMS_Out_Routine.
c		Similarly consolidate Signal handlers.		3-Sep-1983
c	V5.11	Add [NO]Message qualifier to suppress message
c		of the day.					3-Sep-1983
c	V5.12	Get LOGIN time and CPU time for processes.	22-Sep-1983
c	V5.13	Change NAME qualifier to PERSONALNAME,
c		change TTNAME qualifier to TERMINAL,
c		change PRCNAME qualifier to PROCESSNAME.	22-Sep-1983
c	V5.14	Break User_Info according to qualifiers		21-Sep-1983
c	V5.15	Take out space in front of PLAN lines.		22-Sep-1983
c	V5.16	Map "." into self.				22-Sep-1983
c	V5.17	Put "- Subprocess -" into Location		22-Sep-1983
c	V5.18	Move Username <--> Name to Shared COMMON	5-Oct-1983
c	V5.19	Put in personal name matching			6-Oct-1983
c	V5.20	Implement Idle time				6-Oct-1983
c	V5.21	Put terminal data-base into common section	7-Oct-1983
c	V5.22	Put node data into shared common section	10-Oct-1983
c	V5.23	Change idle-time from mm:ss to hh:mm		15-Oct-1983
c	V5.24	change local output open to type='NEW' to fix
c		bug when assigning sys$output to a file.	15-Oct-1983
c	V5.25	Fix typo in JPI item list for OWNER		17-Oct-1983
c	V5.26	Add /FULL (all display qualifiers on)		18-Oct-1983
c	V5.27	Fix load average output bug.			18-Oct-1983
c	V5.28	Fix MailTextInfo multiple message bug (CRW)	29-Oct-1983
c	V5.29	Use Wild_Match routine in Check_Name		4-Nov-1983
c	V5.30	Put in wild cards for node names		4-Nov-1983
c	V5.31	Put in wild cards for personalname match	5-Nov-1983
c	V5.32	Separate the FingerMain file from Finger	5-Nov-1983
c	V5.33	Fix personalname wild cards a bit		7-Nov-1983
c	V5.34	Add STATE & SIZE from BJJ@PSUVMS1		25-Nov-1983
c	V5.35	Include outgoing BITnet linking			25-Nov-1983
c	V5.36	Put in checks for reentrant BITnet call		28-Nov-1983
c	V5.37	Fix several bugs in BITnet stuff		29-Nov-1983
c	V5.38	Put FAO arguments for signal handler		1-Dec-1983
c	V5.39	Close channels (Out-link, and Mail)		2-Dec-1983
c	V5.40	Signal (rather than Exit) on Help error		3-Dec-1983
c	V5.41	Have Finger and subFingers return status. -1
c		means abort.  					5-Dec-1983
c	V5.42	Put in messages and return codes for exits.	7-Dec-1983
c	V5.43	Take out "ERR=" in DECnet read			13-Dec-1983
c	V5.44	Put in error return for Node wild card failure	15-Dec-1983
c	V5.45	Allow "<>" as directory delimitors in Get_Image	15-Dec-1983
c	V5.46	Fix CPU time for overflow.			22-May-1984
c	V5.47	clear a flag before first timeout so wild card
c		node timeouts won't give spurious timeouts	22-Jun-1984
c	V5.48	Change "BITnet" to "jnet" throughout.		17-Jul-1984
c	V5.49	Add network names in Fingershr and on output	17-Jul-1984
c	V5.50	Put Que name in for Batch jobs			19-Jul-1984
c	V5.51	Avoid doing extra GETJPI on outswapped procs.
c		and fix output for same (Ed Miller @SLAC)	9-Aug-1984
c	V5.52	Get remote DECnet node for location		10-Aug-1984
c	V5.53	Work on multile jnet link situation		31-Aug-1984
c	V5.54	Send to IBM nodes a'la Vace (MSG vs CMD)	31-Aug-1984
c	V5.55	Make "Command complete" check case-insensitive	19-Sep-1984
c	V5.56	Buffer RMS output line at a time		19-Sep-1984
c	V5.57	Supply the command "FINGER" if missing on
c		jnet invocations.				20-Sep-1984
c	V5.58	put in ' MSG' at end of command to IBM hosts	26-Sep-1984
c	V5.59	change definition of "system" process slightly	19-Oct-1984
c	V5.60	Fix bug in clearing DECnet site name		23-Oct-1984
c	V5.61	Deassign NET: channel after use:Get_DECnet_Node	24-Oct-1984
c	V5.62	Add routine to get jnet node: Get_jnet_Node	27-Oct-1984
