+-+-+-+ Beginning of part 12 +-+-+-+
Xc   trailing blanks and tabs removed.
Xc   Routine written at CMU PSYA::
X
X`009implicit integer*4 (a-z)
X`009integer countr
X`009character*(*) string
X`009character*1 tab, NUL, space
X`009
X`009NUL = char(0)
X`009tab = char(9)
X`009space = char(32)
X
X`009do 10 countr = len (string), 1, -1
X`009`009if (string (countr : countr) .ne. NUL .and.
X     *`009`009`009string (countr:countr) .ne. space .and.
X     *`009`009`009string (countr:countr) .ne. tab) then
X`009`009`009btrim = countr
X`009`009`009return
X`009`009endif
X10`009continue
X
X`009btrim = 1
X`009return
X`009end
X
X`012
Xc------------------------------------------------------------
X`009Integer Function Priv_UserOpen(FAB,RAB,Unit)
X
Xc  open a system file with privilege.
X
Xc  set bits in the FAB to require EXEC mode logical name
Xc  translation to be used when opening the file and turn
Xc  SYSPRV on for the open.
X
X`009Include`009`009'Fingerdef.inc'
X`009Include '($RMSDEF)/nolist'
X`009Include '($SYSSRVNAM)/nolist'
X`009Include '($FABDEF)/nolist'
X`009Include '($RABDEF)/nolist'
X`009Include '($xabDEF)'
X`009Include`009'XABPRODEF.INC'
X`009Record /FABDEF/Fab, /RABDEF/ rab
X`009Record /XABPRODEF1/ xabpro
X`009Integer*4 LUIC
X`009Common /xab_uic/ LUIC
X`009External XABSET, XABGET
X`009Integer`009`009Privilege(2) /0,0/
Xc`009Byte`009`009FAB$B(0:119)
Xc`009Integer`009`009RAB(30)
Xc`009Integer*4`009Sys$Open, Sys$Connect`009`009![rph] 01-06-88
X`009Integer`009`009Unit
X`009Integer*4       UserUIC,FlgUIC,ownUIC
X`009Common/UseUIC/UserUIC,FlgUIC
X
Xc  set Logical name access to EXEC mode
X`009FAB.FAB$B_ACMODES = FAB.FAB$B_ACMODES .or.
X     1   1
Xc`0091`009( (1) * 2**FAB$V_LNM_MODE)`009`009! require EXEC mode
Xc  fab$V_lnm_mode = 0 so omit ref since define includes double def it
Xc set up xab
X`009If (FlgUIC .ne. 0 ) then
X`009Call XABSET( %VAL (fab.FAB$L_XAB))
X`009EndIf
X
Xc  Turn on SYSPRV privilege
X`009Privilege(1) =  Prv$M_Sysprv
X`009Call Sys$Setprv(%Val(1),Privilege,,)
X
Xc  open file
X`009iii = Sys$Open(FAB)
X`009If (FlgUIC .ne. 0) then
X`009If (iii .eq. rms$_NORMAL) then
X`009  iii= SYS$DISPLAY(fab)
X`009  Call XABGET (%VAL ( fab.FAB$L_XAB))
X`009  OwnUIC=LUIC
Xd`009Write(6,4555)userUIC, ownUIC
Xd4555`009Format(' user UIC=', i12,' FileOwner UIC=',i12)
X`009  if (ownUIC.ne.userUIC) then
X`009`009iii=sys$close(FAB)
X`009  End IF
X`009End if
X`009End If
Xc  Turn off SYSPRV privilege
X`009Call Sys$Setprv(,Privilege,,)
X`009If (FlgUIC .ne.0) then
X`009FlgUIC=0
Xc If flagged for nonzero UIC check, compare file owner UIC
Xc here with userUIC longword and if non equal close the file
Xc and forget it. One pass, to avoid possible problems, since
Xc this is only for FINGER.PLN files.
Xc need $xabpro to get UIC.
X`009  if (ownUIC.ne.userUIC) then
X`009`009iii= sys$open(FAB)
Xc try nonpriv'd open if wrong UIC, in case file IS world readable
Xc but owned by, e.g., some identifier on behalf of the user we're
Xc fingering.
X`009  endif
X`009EndIF
X
X`009If ( .not. iii ) Then
X`009    Priv_UserOpen = iii
X`009    Return
X`009EndIf
X
Xc  connect
X`009Priv_UserOpen = Sys$Connect(RAB)
X
X`009Return
X`009End
X`012
Xc------------------------------------------------------------
X`009Integer Function Priv_Close(Unit)
X
Xc  Close a system file with privilege.  Needed for Files opened with
Xc  privilege in VMS V4.2 (it is rumored)
X
X`009Include`009`009'Fingerdef.inc'
X`009Integer`009`009Privilege(2) /0,0/
X`009Integer`009`009Unit
X
Xc  Turn on SYSPRV privilege
X`009Privilege(1) =  Prv$M_Sysprv
X`009Call Sys$Setprv(%Val(1),Privilege,,)
X
Xc  Close file
X`009Close( Unit = Unit )
X
Xc  Turn off SYSPRV privilege
X`009Call Sys$Setprv(,Privilege,,)
X
X`009Return
X`009End
X`012
Xc-------------------------------------------------------------
X`009Integer*2 Function Get_w_Val(I2)
X
X`009Integer*2`009I2
X
X`009Get_w_Val = I2
X
X`009Return
X
X`009End
X`012
Vc----------------------------------------------------------------------------
X-
X`009Subroutine Make_Info(PID,STS,Prcnam,Username,Terminal,
X`0091`009State, PgCnt, HeaderWritten, TestOutput, FlagProcess)
X
Xc  This routine and subroutine Show_Info are used together to provide
Xc  a sorted output display.  If the command option SORT is turned on,
Xc  user information is written into an array in this subroutine.  Then,
Xc  the array is sorted, and written to the output.
Xc
Xc  Added by  Art Greenberg, RCA Laboratories
X
X`009Include`009`009'GETJPIDEF'
X`009Include`009`009'FingerFlg'
X`009Include`009`009'Fingerdef.inc'
X
X`009Integer`009`009PID_array, STS_array, State_array,
X`0091`009`009PgCnt_array, HeaderWritten, TestOutput,
X`0092`009`009FlagProcess, FP_array
X
X`009Character`009Prcnam_array*15, Username_array*12,
X`0091`009`009Terminal_array*8
X
X`009Dimension`009PID_array(200), STS_array(200),
X`0091`009`009State_array(200), PgCnt_array(200),
X`0092`009`009Prcnam_array(200), Username_array(200),
X`0093`009`009Terminal_array(200), FP_array(200)
X
X`009Common`009/Info/`009PID_array, STS_array, State_array,
X`0091`009`009PgCnt_array, Prcnam_array, Username_array,
X`0092`009`009Terminal_array, Last_Number, FP_array
X
X`009Integer`009`009PgCnt
X`009Integer`009`009Index
X
X`009Data`009`009Index /0/
X
Xc  Initialize the info array if first time thru here.
X
X`009If (PID .eq. 0) then
X`009    Index = 0
X`009    Return
X`009EndIf
X
X`009If (Index .eq. 0) then
X`009    Index = 1
X`009EndIf
X
Xc  Enter one user's information into the info arrays.
X
X`009PID_array(Index)`009= PID
X`009STS_array(Index)`009= STS
X`009Prcnam_array(Index)`009= Prcnam
X`009Username_array(Index)`009= Username
X`009Terminal_array(Index)`009= Terminal
X`009State_array(Index)`009= State
X`009PgCnt_array(Index)`009= PgCnt
X`009FP_array(Index)`009`009= FlagProcess
X
X`009Last_Number`009`009= Index
X`009Index`009`009`009= Index + 1
X
Xc  Done!
X
X`009Return
X
X`009End
X
X`012
Xc------------------------------------------------------------------
X`009Character*20`009Function Get_LastName(Username)
X
X`009Include`009`009'GETJPIDEF'
X`009Include`009`009'FingerFlg'
X`009Include`009`009'Fingerdef.inc'
X
X`009Logical`009`009IsPrint
X
X`009Character`009ToUpper
X`009Character*31`009Get_PersonalName, PersonalName, LastName
X`009Integer`009`009Length, Pointer, Btrim, Index, End
X
X`009PersonalName`009= Get_PersonalName(Username)
X`009Length`009`009= Btrim(PersonalName)
X
X`009if (Length .eq. 1) Then
X`009    Get_LastName = ' '
X`009    return
X`009endif
X
Xc  Have to make sure the name is uppercase for sorting purposes.
X
X`009Index = 1
X`009DoWhile (Index .le. Length)
X`009    PersonalName(Index:Index) = ToUpper(PersonalName(Index:Index))
X`009    Index = Index + 1
X`009EndDo
X
Xc  Scan backward from the end of the name string to isolate the last
Xc  name.
X
X`009Pointer = Length
X`009DoWhile ( IsPrint(PersonalName(Pointer:Pointer)) .and.
X`0091        (Pointer .gt. 0) )
X`009    Pointer = Pointer - 1
X`009EndDo
X`009Pointer = Pointer + 1
X
Xc  Copy the last name into the returned string.
X
X`009LastName = ' '`009`009`009! 20 spaces
X`009Index = 1
X`009End = Length - Pointer + 1
X`009DoWhile (Index .le. End)
X`009    Position = Index + Pointer - 1
X`009    LastName(Index:Index) = PersonalName(Position:Position)
X`009    Index = Index + 1
X`009EndDo
X
Xc  Now concat the balance of the personal name to the last name.  This
Xc  will cause sorting to reconcile people with the same last name.
X
X`009If (Pointer .gt. 1) then
X`009    Get_LastName = LastName(:End) // PersonalName(1:Pointer-1)
X`009Else
X`009    Get_LastName = LastName(:End)
X`009EndIf
X
X`009Return
X
X`009End
X
X
X`012
Xc-------------------------------------------------------------
X`009Integer Function Get_l_Val(I)
X
X`009Integer`009I
X
X`009Get_l_Val = I
X
X`009Return
X
X`009End
X`012
Xc------------------------------------------------------------------
X`009Logical`009`009Function IsPrint(Candidate)
X
X`009Character`009Str$UpCase, Candidate, Temp
X
X`009Temp = Str$UpCase (Candidate)
X
X`009If ( (Temp .gt. ' ') .and. (Temp .lt. 'a') ) then
X`009    IsPrint = .true.
X`009Else
X`009    IsPrint = .false.
X`009EndIf
X
X`009Return
X
X`009End
X
X`012
Xc------------------------------------------------------------------
X`009Character`009Function ToUpper (Candidate)
X
X`009Character`009Candidate
X`009Character*26`009UCase_Alphas, LCase_Alphas
X`009Integer`009`009Place
X
X`009Data`009`009UCase_Alphas /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
X`009Data`009`009LCase_Alphas /'abcdefghijklmnopqrstuvwxyz'/
X
X`009Place = Index(LCase_Alphas, Candidate)
X`009If (Place .ne. 0) then
X`009    ToUpper = UCase_Alphas(Place:Place)
X`009Else
X`009    ToUpper = Candidate
X`009EndIf
X
X`009Return
X
X`009End
X
X`012
X`009Logical Function Wild_Parse( Name, NonWild)`009`009`009!FJN
X
X`009Character*(*) Name`009`009`009`009`009`009!FJN
X`009Integer NonWild`009`009`009`009`009`009`009!FJN
X
X`009Wild_Parse = .false.`009`009`009`009`009`009!FJN
X`009NonWild = 0`009`009`009`009`009`009`009!FJN
X
Vc Scan for wild card characters "*" and "%", count non-wild characters`009!FJ
XN
X
X`009Do i = 1,LEN(Name)`009`009`009`009`009`009!FJN
X`009    If ( Name(i:i) .eq. '*' ) Then`009`009`009`009!FJN
X`009`009Wild_Parse = .true.`009`009`009`009`009!FJN
X`009    Else If ( Name(i:i) .eq. '%' ) Then`009`009`009`009!FJN
X`009`009Wild_Parse = .true.`009`009`009`009`009!FJN
X`009    Else If ( Name(i:i) .ne. ' ' ) Then`009`009`009`009!FJN
X`009`009NonWild = NonWild + 1`009`009`009`009`009!FJN
X`009    End If`009`009`009`009`009`009`009!FJN
X`009Enddo`009`009`009`009`009`009`009`009!FJN
X
X`009Return`009`009`009`009`009`009`009`009!FJN
X`009End`009`009`009`009`009`009`009`009!FJN
X`012
Xc------------------------------------------------------------------
X`009SUBROUTINE XABSET ( xabpro )
XC
X`009INCLUDE 'XABPRODEF.INC'
XC
X`009RECORD`009/XABPRODEF1/ xabpro
XC
X`009INTEGER*4`009l_uic
XC
X`009COMMON`009/XAB_UIC/   l_uic
XC
X`009xabpro.XABPRODEF$$_FILL_1 = XAB$C_PRO`009    ! Type of XAB block.
X`009xabpro.XABPRODEF$$_FILL_2 = XAB$C_PROLEN     ! Length of PRO XAB.
XC`009xabpro.XABPRODEF$$_FILL_4 = 0`009`009    ! Next XAB address.
X`009RETURN
X`009END
XC
X`009SUBROUTINE XABGET ( xabpro )
XC
X`009INCLUDE 'XABPRODEF.INC'
XC
X`009RECORD`009/XABPRODEF1/ xabpro
XC
X`009INTEGER*4`009l_uic
XC
X`009COMMON`009/XAB_UIC/   l_uic
XC
X`009l_uic = xabpro.XAB$L_UIC
X`009RETURN
X`009END
X
X`012
Xc------------------------------------------------------------------
Xc`009Update history / implementation notes -
Xc
XC`009V1.00`009Base version Working with DEC-20`009June 1982
XC`009V1.01`009Index of nodes with routing`009`009June 1982
XC`009V1.02`009Return open error message on failure
XC`009`009to establish link to next node`009`009July 1982
XC`009V1.03`009Slight change in task spec for VMS V3.0`009July 1982
XC`009V1.04`009Add image name information`009`009July 1982
XC
XC`009V2.00`009Start looking for individuals`009`009July 1982
XC`009V2.01`009Clean up IO units`009`009`009July 1982
XC`009V2.02`009Clean up LOCATION, NAME & IMAGE`009`009July 1982
XC`009V2.03`009Fix individual finger w. wildcards`009Aug. 1982
XC`009V2.04`009Put GETJPI stuff in include file`009Aug. 1982
XC
XC`009V3.00`009Combine local and network invocation`009Aug. 1982
XC`009V3.01`009Consolidate IO units into COMMON`009Aug. 1982
XC`009unspec`009Added terminal display -- PSYA::LUCAS`009Sep. 1982
XC`009V3.02`009Added typing of <username>.PLN files`009
XC`009`009when fingering a specific user, as well
XC`009`009as telling if user has any new mail
XC`009`009messages. -- PSYA::OHLUND`009`009Sep. 1982
XC`009V3.03`009Change <username>.PLN to FINGER.PLN Rg`009Sep. 1982
XC`009V3.04`009Fix a few bugs. Rg`009`009`009Sep. 1982
XC`009V3.10`009Get personal name from UAF`009`009Nov. 1982
XC`009V3.20`009Get load averages`009`009`009Nov. 1982
XC`009V3.25`009Get node name from SYS$NODE`009`009Nov. 1982
XC`009V3.30`009Get current Mail messages`009`009Nov. 1982
XC`009V3.35`009Get day of the week`009`009`009Nov. 1982
XC`009V4.00`009Complete cleanup and rationalization`009`00915-Nov-1982
Xc`009V4.01`009Fix bug in Get_Image scanning for image name`00916-Nov-1982
Xc`009V4.02`009"Make_Pretty" the image name. Put all "Make_Pretty"'s
Xc`009`009in Output routines.`009`009`009`00918-Nov-1982
Xc`009V4.03`009Remove all Str$UpCase calls but the 1st
Xc`009`009in routine Finger and in Make_Pretty.`009`00918-Nov-1982
Xc`009V4.04`009Make load device a parameter`009`009`00922-Nov-1982
Xc`009V4.05`009Fix mail-messages > 99 bug.`009`009`00923-Nov-1982
Xc`009V4.06`009Put in handler to catch signalled errors
Xc`009`009and route messages back to requesting node`00917-Dec-1982
Xc`009V4.07`009Fix bug in MailTextInfo "From:" message.`009 6-Jan-1983
Xc`009V4.08`009Slight mod in load average output statement.`00917-Mar-1983
Xc`009V4.09`009Put in BITnet for location for PTys`009`00924-Apr-1983
Xc
Xc`009V5.00`009Restructure program to use callable output
Xc`009`009routine.  This is in anticipation of other
Xc`009`009network support.`009`009`009`00919-May-1983
Xc`009V5.01`009Allow terminal names to 6 char (7 including the
Xc`009`009":"). This allows 3 digit numbers, e.g. TTC123`00919-May-1983
Xc`009V5.02`009Put in limits to the number of messages output
Xc`009`009by the signal_handlers to catch runaway error
Xc`009`009loops`009`009`009`009`009`00919-May-1983
Xc`009V5.03`009Add CPU type and VMS version to header.`009`00920-May-1983
Xc`009V5.04`009Add display qualifiers to .CLD file`009`0094-Jun-1983
Xc`009`009In anticipation of having all display options
Xc`009`009selectable by the user.
Xc`009V5.05`009add "no such jobs." message.`009`009`0094-Jun-1983
Xc`009V5.06`009Change Flag integers to parameters`009`0096-Jun-1983
Xc`009V5.06`009Check for NET, SUBPROCESS, and SYSTEM jobs`0096-Jun-1983
Xc`009V5.07`009Move flag definitions to include file.`009`0097-Jun-1983
Xc`009V5.08`009Fix wrong mask PCB$M_NETWRK`009`009`0099-Jun-1983
Xc`009V5.09`009Change OPEN statement for load average due
Xc`009`009to aparent VMS change in V3.2`009`009`00918-Aug-1983
Xc`009V5.10`009Use Fortran IO instead of LIB$PUT_SCREEN locally
Xc`009`009to avoid screw ups on hard copy devices. Consolidate
Xc`009`009DECnet and local output routine: RMS_Out_Routine.
Xc`009`009Similarly consolidate Signal handlers.`009`0093-Sep-1983
Xc`009V5.11`009Add [NO]Message qualifier to suppress message
Xc`009`009of the day.`009`009`009`009`0093-Sep-1983
Xc`009V5.12`009Get LOGIN time and CPU time for processes.`00922-Sep-1983
Xc`009V5.13`009Change NAME qualifier to PERSONALNAME,
Xc`009`009change TTNAME qualifier to TERMINAL,
Xc`009`009change PRCNAME qualifier to PROCESSNAME.`00922-Sep-1983
Xc`009V5.14`009Break User_Info according to qualifiers`009`00921-Sep-1983
Xc`009V5.15`009Take out space in front of PLAN lines.`009`00922-Sep-1983
Xc`009V5.16`009Map "." into self.`009`009`009`00922-Sep-1983
Xc`009V5.17`009Put "- Subprocess -" into Location`009`00922-Sep-1983
Xc`009V5.18`009Move Username <--> Name to Shared COMMON`0095-Oct-1983
Xc`009V5.19`009Put in personal name matching`009`009`0096-Oct-1983
Xc`009V5.20`009Implement Idle time`009`009`009`0096-Oct-1983
Xc`009V5.21`009Put terminal data-base into common section`0097-Oct-1983
Xc`009V5.22`009Put node data into shared common section`00910-Oct-1983
Xc`009V5.23`009Change idle-time from mm:ss to hh:mm`009`00915-Oct-1983
Xc`009V5.24`009change local output open to type='NEW' to fix
Xc`009`009bug when assigning sys$output to a file.`00915-Oct-1983
Xc`009V5.25`009Fix typo in JPI item list for OWNER`009`00917-Oct-1983
Xc`009V5.26`009Add /FULL (all display qualifiers on)`009`00918-Oct-1983
-+-+-+-+-+ End of part 12 +-+-+-+-+-