C..Finger.For				VAX/VMS Finger program
C..					R. Garland / C.U. Chemistry / Oct-1983
	Program	Finger$Main

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 V3.0 or later
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-
C		FINGERSHR (shared common section) in this submission.
C			Note:  This shared section is maintained by
C				the SHR program in this submission.
C		IDLE (IDLE.MAR) in this submission.
C		FLINERCLI ( .CLD table ) in this submission
c
C		All other routines other than VMS system services and
C		VMS library routines are contained in this source.
C
C	Include files-
C		GETJPIDEF.FOR: (in this submission) contains
C		    definitions and data declarartions for the $GETJPI
C		    system service.
c		FINGERCOM.FOR: (in this submission) definitions of the
C		    shared common sections.
c		FINGERFLG.FOR (part of this submission) contains
C		    Bit definitions used in parsing the command qualifiers.
c
C	Implementation and installation notes-
C		See separate document in this submission.
C
C	Edition/changes-
C
c	Note:	Early update history is at the end of this source.
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
	Character	Command*132
	Character	Lib$Get_Foreign*132, Str$UpCase*132
	Character	Net$Lognam*7	/'SYS$NET'/
	Character	Out$Lognam*10	/'SYS$OUTPUT'/
	Character	Rslbuf*132
	Integer		Sys$Trnlog, SS$_Status,	SS$_NoTran/Z00000629/
	Integer		SS$_Normal/1/,	Btrim
	External	RMS_Signal_Handler, RMS_Out_Routine

	Parameter	InboundLinkUnit	= 10

C Find the type of invocation, and call Finger appropriately.
c
c  Note:  For the particular invocation one must do 3 things:
c	o Get the Finger command from the invoker.
c	o Establish a channel and an appropriate output
c	  routine to send the output of finger to the invoker.
c	o Establish a signal handler to route error messages back
c	  to the invoker.
c
c	The current version supports Local invocation and DECnet invocation.

C  Check if SYS$NET is defined, if so we are a DECnet invocation

	SS$_Status = Sys$Trnlog(Net$Lognam,,Rslbuf,,,)

	If ( SS$_Status .eq. SS$_Normal ) then		! DECnet invocation
C	    Network object finger.  It differs from the local 
C	    version only in unit assignment, and in where it gets
C	    the finger command.
C	  Get command 
	    Open( Unit=InboundLinkUnit,
	1	Name=Net$Lognam,
	2	Type='OLD',
	3	CarriageControl='NONE')
	    Read (InboundLinkUnit,1001) l_Com, Command
	    Command = Str$UpCase(Command)
C	  Establish handler for error messages, call finger routine
	    Call Lib$Establish(RMS_Signal_Handler)
	    Call Finger(Command(:l_Com),RMS_Out_Routine)

	ElseIf ( SS$_Status .eq. SS$_NoTran ) Then	! Local invocation
C	    Local invocation.  It differs from the network object version 
C	    only in unit assignment, and in where it gets the finger 
C	    command.
C	  Get command 
	    Command = 'FINGER '//Lib$Get_Foreign(,l_Com)
	    l_Com = l_Com + 7
	    Command = Str$UpCase(Command)
	    Open( Unit=InboundLinkUnit,
	1	Name=Out$Lognam,
	2	Type='NEW',
	3	CarriageControl='NONE')
C  	  Establish handler for error messages, call finger routine
	    Call Lib$Establish(RMS_Signal_Handler)
	    Call Finger(Command(:l_Com),RMS_Out_Routine)

	EndIf
C  Done
	Call Exit

1001	Format(Q,A)

	End
c-------------------------------------------------------------------------
	Integer Function RMS_Signal_Handler(
	1	SignalVector,MechanismVector)

c  The point of this handler is really error message routing rather
c  than actually responding to a particular condition.  The routine
c  convert all signals into messages for transmission to the invoker.
c  This routine uses RMS_Out_Routine so it should work for local
c  or DECnet invocations. The routine exits with a CONTINUE flag.  If
c  there are errors that should actually be handled (arithmetic or
c  whatever) by some system handler,  they will not be.

	Integer		SignalVector(8),	MechanismVector(5)
	Integer		Message_Limit/10/,	Message_Count/0/
	Integer		SS$_Status,	SS$_Normal/1/
	Integer		SS$_Unwind/Z00000920/
	Integer		MsgLen
	Character	Msg*132
	Character	CR /13/,	LF /10/,	SP /' '/

	RMS_Signal_Handler = SS$_Normal	! Continue after condition
	SS$_Status = SignalVector(2)
	If ( SS$_Status .eq. SS$_Normal ) Return
	Call Sys$Getmsg(%Val(SS$_Status),Msglen,Msg,%VAL(1),)
	Call RMS_Out_Routine(LF//'?Finger: '//
	1    Msg(:Msglen)//CR//LF)
	Message_Count = Message_Count + 1
	If ( Message_Count .ge. Message_Limit ) then
	    Call RMS_Out_Routine(LF//'?Finger: '//
	1	'Message limit exceeded, aborting.'//CR//LF)
	    RMS_Signal_Handler = SS$_Unwind
	EndIf
	Return

1001	Format(A)
	End

c-------------------------------------------------------------------------
	Subroutine RMS_Out_Routine(Text)

c	This routine types output locally or over DECnet

	Character	Text*(*)

	Parameter	InboundLinkUnit = 10

	Write(InboundLinkUnit,1000) Text

	Return

1000	Format(A)
	End

c-------------------------------------------------------------------------
	Subroutine Finger(Command,Finger_Out_Routine)

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.

	Character VersionMsg*45
	1	/'VAX/VMS Finger: Version V5.27 of 18-Oct-1983 '/
	Common	/Version_Common/ VersionMsg

	Integer		Btrim
	Character	Command*(*)
	Character	Expanded_Command*132
	Character	Node*12, Next_Node*12, Get_Node*12
	Character	Route*72, Node_Type*1
	Character	CR /13/,	LF /10/,	SP /' '/
	Character	Slash /'/'/

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

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

	External	Finger_Out_Routine

	l_com = Len(Command)

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

C  Find node name
	Do ii=l_Com,1,-1
	    If ( Command(ii:ii) .eq. '@' ) Then
		i_At = ii
		GoTo 110
	    EndIf
	EndDo
	Call Local_Finger(Command(:l_Com),Finger_Out_Routine)	! No node name:
								! local finger
	Return

110	Continue
	Node = Command(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

	Next_Node = Get_Node(Node(:l_Node),Node_Type,Route)
C  Format  command 
	Expanded_Command = Command(:i_At-1)//
	1	Route(:Btrim(Route))//
	2	Command(i_AT+l_Node+1:l_Com)

c  check type of node

	If ( Node_Type .eq. 'L' ) Then
c  Local
	    Call Local_Finger(Expanded_Command,Finger_Out_Routine)
	Else If ( Node_Type .eq. 'D' ) then
c  DECnet
	    Call DECnet_Finger(Next_Node(:Btrim(Next_Node)),
	1	Expanded_Command(:Btrim(Expanded_Command)),
	2	Finger_Out_Routine)

	Else if ( Node_Type .eq. 'B' ) then
c  BITnet
	    Call Finger_Out_Routine(LF//'?Finger: BITnet support '//
	1	'not yet implemented.'//CR)
	End if

C Done
	Return

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

	Include		'FingerCom.For'

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

	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 DECnet
	Get_Node = Node
	Node_Type = 'D'
	Route = ' '
	Return

	End

c------------------------------------------------------------------------
	Subroutine 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.

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

	Character	Line*32000,	NUL/0/
	Character	CR /13/,	LF /10/,	SP /' '/
	Character	OpenMsg*80

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

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

	Integer		OutLinkOpenStatus
	Common		/OutLinkOpen_Common/ OutLinkOpenStatus

	External	Finger_Out_Routine
	External	OutLink_UserOpen

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  Notify requester that link is open
	Call Finger_Out_Routine('['//Next_Node//']'//CR//LF)
	GoTo 150

c  Error establishing link
145	Call Sys$Getmsg(%Val(OutLinkOpenStatus),Msglen,OpenMsg,%VAL(1),)
	Call Finger_Out_Routine(LF//'?Finger: For node '//
	1	Next_Node//' - '//OpenMsg(:Msglen)//CR//LF)
	Return

c  Send command over link
150	Write(OutboundLinkUnit,1002)
	1	Net_Command//CR//LF

C  Read response from network
	DoWhile(.true.)
	    Read(OutboundLinkUnit,1001,End=200,Err=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

	Return

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

	End

c------------------------------------------------------------------------
	Subroutine Local_Finger(Command,Finger_Out_Routine)

	Character VersionMsg*45
	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/
	Integer		SS$_Status, Sys$Waitfr, Btrim
	Integer*2	NewMes
	Integer		TestOutput,	FlagProcess
	Logical		ValidID,	TestName
	Logical		Get_ID,		Check_Name,	Check_Process
	Logical		LoggedIn
	Integer		Lbr$Ini_Control,Lbr$Open,	Lbr$Get_Help
	Integer		LbrIndex,	LbrFunc,	Lbr$C_Read/1/
	External	Do_Help

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


	l_Com = Len(Command)
	Call Open_Units

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)
	    LbrFunc = Lbr$C_Read
	    ii_stat1 = Lbr$Ini_Control(LbrIndex,LbrFunc)
	    If ( .not. ii_stat1) Call Exit(ii_stat1)
	    ii_stat2 = Lbr$Open(LbrIndex,'SYS$HELP:HELPLIB.HLB')	
	    If ( .not. ii_stat2) Call Exit(ii_stat2)
	    ii_stat3 = Lbr$Get_Help(LbrIndex,,Do_Help,
	1	Finger_Out_Routine,'FINGER...') 
	    If ( .not. ii_stat3) Call Exit(ii_stat3)
	    If ( .not. (ii_stat1.or.ii_stat2.or.ii_stat3) ) 
	1	Call Finger_Out_Routine(LF//
	2		'Sorry, HELP is not available'//CR)
	    Call Finger_Out_Routine(LF)
	    Return
	EndIf

	LoggedIn = .False.
	If ( (Testoutput.and.FlagIdleTime) .ne. 0 )
	1	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				! 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
	DoWhile(Sys$Getjpi(,PID_Wildcard,,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,ComName) ) Then
		    LoggedIn = .true.
		    Call User_Info(PID,STS,Prcnam,Username,Terminal,
	1		TestOutput,FlagProcess,Finger_Out_Routine)
		EndIf
	    EndIf
	EndDo
	If ( .not. TestName .and. .not. LoggedIn )
	1   Call Finger_Out_Routine(LF//' no such jobs.')

200	Continue

C  Check if personal information is requested
	ValidID = Get_ID(ComName, Directory, NewMes, Name)
	If ( TestName .and. .not. LoggedIn ) Then
	    If ( ValidID ) Then
		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)
	    Else 
		TComName = Get_Username(ComName(:btrim(ComName)),
	1	    NMatches,.true.,Finger_Out_Routine)
		If ( NMatches .eq. 1 )
	1	    ValidID = Get_ID(TComName,Directory,NewMes,Name)
		If ( NMatches .eq. 0 )
	1	    Call Finger_Out_Routine(LF//
	2		ComName(1:btrim(ComName))//
	3		': no such user.'//CR)
	    EndIf
	EndIf

C  Print out Mail info and Plan if user is valid
	IF (TestName .and. ValidID ) Then
	    Call Personal_Info(ComName, Directory, NewMes,
	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'

	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

	TestName = .true.
	TestOutput = 0

	l_Com = Len(Command)
	Call Cli$Dcl_Parse(Command(:l_Com),FingerCli_Table)
	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$Getjpi(,,,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  If nothing else on, turn on FlagInteractive
	If ( TestOutput .eq. 0 ) TestOutput = FlagInteractive

c  Miscellaneous stuff
	If ( Cli$Present('SORT') )
	1	TestOutput = TestOutput .or. FlagSort
	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('IDLETIME') )
	1	TestOutput = TestOutput .or. FlagIdleTime
	If ( Cli$Present('LOCATION') )
	1	TestOutput = TestOutput .or. FlagLocation
	If ( Cli$Present('TTTYPE') )
	1	TestOutput = TestOutput .or. FlagTTType
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*7
	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 = 1

	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 .eq. 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		'FingerFlg.For'
	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$_NoTran/Z00000629/
	Integer		Sys$AscTim, Sys$GetTim, Sys$TrnLog, Sys$GetSYI
	Integer		Btrim
	Integer		SYI_ItemList(7)
	Integer*2	SYI_ItemList2(14)
	Equivalence	(SYI_ItemList,SYI_ItemList2)
	Integer		SYI$_CPU /Z00000200/
	Integer		SYI$_Version /Z00000100/
	Integer		CPU_Type
	Integer		l_CPU, l_Vrsn
	Character	System_Version*8
	Character*3	CPU_Types(3) /'780','750','730'/
	Character	Node$Lognam*8 /'SYS$NODE'/,	Node*9
	Character	AscTime*23, AscSince*23, Make_Pretty*23
	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
	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./

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

c   Set up item list for GetSYI
	SYI_ItemList2(1) = 4		! 4 bytes for CPU type
	SYI_ItemList2(2) = SYI$_CPU	! CPU type
	SYI_ItemList(2) = %Loc(CPU_Type)
	SYI_Itemlist(3) = %Loc(l_CPU)	! returned length
	SYI_ItemList2(7) = 8		! 8 bytes
	SYI_ItemList2(8) = SYI$_Version	! System version
	SYI_ItemList(5) = %Loc(System_Version)
	SYI_ItemList(6) = %Loc(l_Vrsn)	! returned length
	SYI_ItemList(7) = 0	! no more items
	Call Sys$GetSYI(,,,SYI_ItemList,,,)
	Call Sys$Waitfr()

	SS$_Status = Sys$TrnLog(Node$Lognam,l_Node,Node,,,)	! Node name
	If ( SS$_Status .eq. SS$_Notran ) Then
	    Node = ' Finger'
	    l_Node = 9
	EndIf
	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)
	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=12,
	4	Err=101)
	Read(ScratchUnit,2000,Err=101) Load1, Load5, Load15
	Close(Unit=ScratchUnit)
	LoadAvailable = .true.
101	Continue

C  Print full header
C		1st line
	Call Finger_Out_Routine(LF//
	1			Node(2:l_Node-2)//' '//
	2			'VAX 11/'//
	3			CPU_Types(Cpu_Type)//', '//
	4			'VMS '//
	5		 	System_Version(:Btrim(System_Version))//
	6			'. '//
	7			Today(:Btrim(Today))//', '//
	8			AscTime(:17)//', ')
	Write(Temp,1001)	Ijobs, ' Users, '
	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			' Up since '//
	2			Upday(:Btrim(Upday))//', '//
	3			AscSince(:17))
	If ( LoadAvailable ) Then
	    Write(Temp,1002) 	', Load: '	! Site-specific
	1			,Load1 		! Site-specific
	    Call Finger_Out_Routine(Temp(:13))
c	2    			,Load5		! Site-specific
c	3    			,Load15		! Site-specific
c	    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:',
	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	    Close(Unit=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)

	External	Finger_Out_Routine

	Integer		SS$_Status, SS$_NoTran/Z00000629/
	Integer		Sys$AscTim, Sys$GetTim, Sys$TrnLog
	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
	SS$_Status = Sys$TrnLog(Node$Lognam,l_Node,Node,,,)	! Node name
	If ( SS$_Status .eq. SS$_Notran ) Then
		Node = ' Finger'			! In case there is none
		l_Node = 9
	EndIf
	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(2:l_node-2)//
	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.

	Character	Username*12, ComName*12

	Check_Name = .false.

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

c  Check for wild-card
	i_Star = Index(ComName,'*')
	If ( i_Star .eq. 0 ) Return
	If ( Username(:i_Star-1) .eq. ComName(:i_Star-1)) 
	1	Check_Name = .true.

	Return
	End


c-----------------------------------------------------------------------------
	Subroutine User_Info(PID,STS,Prcnam,Username,Terminal,
	1	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.FOR'
	Include		'FingerFlg.For'

	Integer		TestOutput,	FlagProcess
	Integer		CPU_Min,	CPU_Sec
	Character	PID_String*8
	Character	Location*25,	Get_Location*25
	Character	Make_Pretty*20
	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	CR /13/, LF /10/
	Logical		Header_Written /.false./

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

	Write(PID_String,1001) PID
	Do II = 1,4
	    If ( PID_String(II:II) .eq. ' ') PID_String(II:II) = '0'
	End do
	Call NULToSP(Terminal,7)
	Call NULToSP(Prcnam,15)
	Name = Make_Pretty(Get_PersonalName(Username))
	Image = Make_Pretty(Get_Image(PID,LoginTim,CPUTim))
	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)
	Write(CPU_Time,1002) CPU_Min, CPU_Sec
	If ( CPU_Time(5:5) .eq. ' ' ) CPU_Time(5:5) = '0'
	If ( (Testoutput.and.FlagIdleTime) .ne. 0 )
	1	Idle_Time = Get_Idle(PID)
	Location = Get_Location(Terminal,TTType)
	If ( (FlagProcess.and.FlagSubprocess) .ne. 0 ) then
	    Location = '- Subprocess -'
	    TTType = ' '
	Else If ( (STS.and.Pcb$m_Batch) .ne. 0 ) Then
	    Location = '- Batch -'
	    TTType = ' '
	End If

c  Column headings
	If ( .not. Header_Written ) 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 )
	1	Call Finger_Out_Routine('Term ')
c or	1	Call Finger_Out_Routine('Term   ')
	    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.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)
	    Header_Written = .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 )
	1	Call Finger_Out_Routine(Terminal(1:4)//' ')
c or	1	Call Finger_Out_Routine(Terminal(1:6)//' ')
	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.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)

	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

	Parameter	max_units = 128
	Integer		Idl$I_Times(max_units)
	Integer		Idl$I_PIDs(max_units)
	Integer		I_Idle, I_hr, I_min
	Integer		PID

	Common		/Idle_Common/
	1		Idl$I_Times,
	2		Idl$I_PIDs

	Get_Idle = ' '

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

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

1000	Format(I2,':',I2)

	End

c-----------------------------------------------------------------------------
	Subroutine Get_Idle_Times

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

	Parameter	max_units = 128
	Integer		Idl$I_Times(max_units)
	Integer		Idl$I_PIDs(max_units)

	Common		/Idle_Common/
	1		Idl$I_Times,
	2		Idl$I_PIDs

	IStatus = Idle(Idl$I_Times,Idl$I_PIDs,max_units)
	If ( .not. IStatus ) Call Lib$Signal(IStatus)
	Return

	End

c-----------------------------------------------------------------------------
	Character*25	Function Get_Location(Terminal,TTType)

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 BITnet.  These can be ignored
c  if you don't have them, otherwise change appropriately.

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'

	Character	Terminal*7, TTType*25

	Get_Location = ' '	! If location can't be found
	TTType = ' '

	If ( Terminal(1:2) .eq. 'RT' ) Then
	    Get_Location = '- DECnet -'
	ElseIf ( Terminal(1:2) .eq. 'PT' ) Then	! Site-specific
	    Get_Location = '- BITnet -'		! If you have pseudoterminals
						! you'll know what to do
	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*9	Function Get_Image(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 = 'CHEM$SYSROOT:[USER]'! These 2 for..
c	Parameter	PublicDirectory3 = 'WORK$:[SYS.USER]'	! my site -Rg
c	Parameter	PublicDirectory4 = 'DBA0:'		! an example
c	Parameter	PublicDirectory5 = 'DRA1:[LOCAL]'	! an example
c
c  ! Site-specific: end of note

C  Include all GETJPI data and definitions
	Include		'GETJPIDEF.FOR'

	Get_Image = '<unavail>'

C  Set up item list for GETJPI
	I = 1
	II = 1
	ITEM_LIST2(II+IC) =	JPI$_IMAGNAM
	ITEM_LIST2(II+BL) =	L_IMAGNAM
	ITEM_LIST(I+BA)  =	%LOC(IMAGNAM)
	ITEM_LIST(I+RL)  =	%LOC(RL_IMAGNAM)
	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
	If ( .not. Sys$Getjpi(,PID,,Item_List,,,) ) Return
	Call Sys$Waitfr()

c  Check for no image (DCL)
	If ( Imagnam(:Rl_Imagnam) .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(Imagnam,PublicDirectory1)	!
c	i_Dir2 = Index(Imagnam,PublicDirectory2)	! to be set
c	i_Dir3 = Index(Imagnam,PublicDirectory3)	! above for
cc	i_Dir4 = Index(Imagnam,PublicDirectory4)	! each site. 
cc	i_Dir5 = Index(Imagnam,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.
	i = Index(Imagnam(:Rl_Imagnam),']')
	ii = Index(Imagnam(i:Rl_Imagnam),'.') + i-1
	Get_Image = Imagnam(i+1:ii-1)

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

	Include		'FingerCom.For'

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

	Call NULToSP(Username,12)
	Owner = ' '		! default if name not found

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

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  ! site-specific:	set minimum match length or omit. (see below)
	Parameter	minimum_match_length = 3

	Include		'FingerCom.For'

	Integer		NMatches
	Logical		OutFlag, ExactMatch, Match
	External	Out_Routine
	Character	Owner*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
c	If ( Len(PersonalName) .lt. minimum_match_length ) then
c	    ExactMatch = .true.
c	Else
	    ExactMatch = .false.
c	End if

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 ( 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		'Sunday',
	2		'Monday',
	3		'Tuesday',
	4		'Wednesday',
	5		'Thursday',
	6		'Friday',
	7		'Saturday'/

	Integer		BinTime(2), DayNumber

	Call Lib$Day(DayNumber,BinTime)
	ii = Mod(DayNumber+3,7) + 1	! day 0 was a Wednesday, hence the "+3"
	Day_OfTheWeek = Day(ii)

	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 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

	Common	/OutLinkOpen_Common/ OutLinkOpenStatus

	iii = Sys$Create(FAB)
	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---------------------------------------------------------------------
	Subroutine Personal_Info(UserName, Directory, NewMes,
	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

	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

	Integer*2	NewMes
	Integer		SS$_Status,	Sys$Crmpsc
	Integer		MailOpenStatus,	MailFileChan
	Common		/MailOpen_Common/  MailOpenStatus, MailFileChan
	External	MailFile_UserOpen
	Integer		MailTextDescr(2)
	Integer		Inadr(2)/0,0/,	Retadr(2)
	Integer		Flags/z00020000/

	Character	Temp*25
	Character*50	MailFile, PlanFile, Directory
	Character*12	UserName
	Character*132	Line
	Character*1	LF/10/, CR/13/
	Integer		Btrim
	Integer		TestOutput
	Include		'FingerFlg.For'

C  Mail information
	If ( (TestOutput.and.FlagMail) .ne. 0 ) then
	  Call Finger_Out_Routine(LF//' Mail: ')
	  If (NewMes .gt. 0) then
	    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.
	    MailFile = Directory(1:Btrim(Directory))//'MAIL.MAI'
	    Open(	Unit=ScratchUnit,
	1		File=MailFile,
	2		Type='Old',
	3		Shared,
	4		ReadOnly,
	5		Err=101,
	6		UserOpen=MailFile_UserOpen)
	    SS$_Status = Sys$Crmpsc(Inadr,Retadr,,%Val(Flags),
	1		,,,%Val(MailFileChan),,,,)
	    If ( .not. SS$_Status ) GoTo 100
	    MailTextDescr(1) = Retadr(2) - Retadr(1)
	    MailTextDescr(2) = Retadr(1)
	    If ( MailTextDescr(1) .ge. 32768 ) Then
		MailTextDescr(1) = 32767
		MailTextDescr(2) = Retadr(2) - 32767
	    Endif
	    Call MailTextInfo(MailTextDescr,Finger_Out_Routine)
100	    Close(Unit=ScratchUnit)
101	    Continue		! No Mail file (Open failure)
c  ! Site-specific - end of section
	  Else
	    Call Finger_Out_Routine('(no new mail)'//CR)
	  Endif

C  1 blank line
	  Call Finger_Out_Routine(LF//CR)
	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: ')

	  PlanFile = Directory(1:Btrim(Directory))//PlanFileName1
	  Open (	Unit=ScratchUnit,
	1	File=PlanFile,
	2	Status='old',
	3	Err=201,
	4	Shared,
	5	Readonly)
	  GoTo 250

c  Error opening Plan File - look for an alternate.
201	  Continue
	  PlanFile = Directory(1:Btrim(Directory))//PlanFileName2
	  Open (	Unit=ScratchUnit,
	1	File=PlanFile,
	2	Status='old',
	3	Err=202,
	4	Shared,
	5	Readonly)
	  GoTo 250

c  look for another - or give up ! Site-specific
202	  Continue
	  GoTo 301
c	  PlanFile = Directory(1:Btrim(Directory))//PlanFileName3
c	  Open (	Unit=ScratchUnit,
c	1	File=PlanFile,
c	2	Status='old',
c	3	Err=301,
c	4	Shared,
c	5	Readonly)
c	  GoTo 250

c  Found the file - list it.
250	  Call Finger_Out_Routine(CR)
	  DoWhile(.True.)
	    Read(ScratchUnit,2000,End=300) l_line, Line
	    Call Finger_Out_Routine(LF//Line(1:l_line)//CR)
	  EndDo
300	  Close(Unit=ScratchUnit)
	  Return

C  Here if no plan file
301	  Continue
	  Call Finger_Out_Routine('(no plan file)'//CR)
	EndIf

	Return

1001	Format(I1,A)
1002	Format(I3,A)
2000	Format(Q,A)

	End

c------------------------------------------------------------
	Integer Function MailFile_UserOpen(Fab,Rab,Unit)

c  Set the UFO bit on in the FOP field so file can be mapped
c  The 2nd word of the FAB is Fab$l_FOP

	Integer		Fab(30), Rab(30)
	Integer		Fab$m_UFO/Z00020000/
	Integer		Sys$Open
	Integer		Unit, MailOpenStatus, MailFileChan

	Common	/MailOpen_Common/ MailOpenStatus, MailFileChan

	Fab(2) = Fab(2) .or. Fab$M_UFO	! 2nd longword is FOP field
	MailOpenStatus = Sys$Open(FAB)
	MailFileChan = Fab(4)

	MailFile_UserOpen = MailOpenStatus
	Return
	End

c-----------------------------------------------------------------------
	Subroutine MailTextInfo(FileString,Out_Routine)

c  ! VMS-specific V3.0 - check in future releases of MAIL.
c  Search for unread messages in VMS type MAIL file.  The
c  file is mapped to the string "FileString".  Finding the
c  message depends on the assumption that the file is a VMS
c  variable length record file with the length in a word 
c  preceding the line.  VMS MAIL also puts a "*" at the end
c  of the "From:" line for unread messages.

	External	Out_Routine

	Integer		Unit
	Character*(*)	FileString
	Character*1	LF/10/, CR/13/

	i = 1
	ilen = Len(FileString)
	DoWhile(.true.)
	    ii = Index(FileString(i:),'From:')
	    If ( ii .eq. 0 ) Return
	    i = i+ii
	    If ( Ichar(FileString(i-2:)) .eq. 0 ) Then
		iii = Ichar(FileString(i-3:))		! length of line
		If ( i+iii-2 .gt. ilen ) Return
		If ( FileString(i+iii-2:i+iii-2) .eq. '*' )
	1	Call Out_Routine(LF//'       '//
	2			FileString(i-1:i+iii-2)//
	3			CR)
	    EndIf
	EndDo

1000	Format(A)
	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--------------------------------------------------------------------------
	Logical	Function Get_ID(UserName, Directory, NewMes, Name)

c   Function to return the default login device and directory and
c   also determine if the user has new mail. 
c   Adapted from routine "Get_Directory" written at CMU PSYA::

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

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

	Character*50	Directory
	Character*12	UserName
	Character*25	Name,	Owner,	Fix_Name
	Logical*1	Record(272)
	Logical*1	Defdir(32),	Defdev(16)
	Integer*2 	Grp,	Mem,	Mail,	NewMes
	Equivalence	(Mem, Record(17))
	Equivalence	(Grp, Record(19))
	Equivalence	(Owner, Record(115))
	Equivalence	(Mail, Record(187))
	Equivalence	(Defdir, Record(20))
	Equivalence	(Defdev, Record(53))

	Read(Unit=UafUnit,KeyEq=UserName,
	1	IoStat=Ios,err=999) UserName, Record

c  Fix name: LAST,FIRST --> First Last
	Name = Fix_Name(Owner)

c   Concatenate the DEFDEV and DEFDIR into one string Directory.
	i=1
10	i = i + 1
	Directory(i:i) = char(defdev(i))
	if (defdev(i) .ne. ':') goto 10
	j = 2
20	j = j + 1
	i = i + 1
	Directory(i:i) = char(defdir(j))
	if (defdir(j) .ne. ']') goto 20
	Directory(i+1:) = ' '
	Get_ID = .true.
	NewMes = Mail
	Close (unit=30)
	Return

999	Get_ID = .false.

	Return
	End

c-------------------------------------------------------------
	Subroutine Open_Units

C  Note: Unit numbers are defined in data initialization in main program.

	Integer		
	1		OutboundLinkUnit, 
	2		UafUnit,
	3		ScratchUnit

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

c
	Open(Unit=UafUnit,
	1	File='Sys$System:Sysuaf',
	2	Status='Old',
	3	Organization='Indexed',
	4	Access='Keyed',
	5	Form='Unformatted',
	6	Recl=1052/4,
	7	Key=(1:12:Character), 
	8	Readonly, 
	9	Shared)

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

	Integer*2	I2

	Get_w_Val = I2

	Return

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

	Integer	I

	Get_l_Val = I

	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