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 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 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 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 V47.1.00 of 04-Apr-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 (.not.(index('V',CPU_Type))) 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=12, 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/ 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 = '' 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 Call Get_Queue_Name(PID,Quename,ll) c Turn off SYSPRV privilege Call Sys$Setprv(,Privilege,,) Location = 'Q.'//Quename(:ll) 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' 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/ Character*15 Name Character*16 Junk1 Integer*2 Flags Integer*2 Newmail Character*30 Junk2 Byte Directory_Length Byte Name_Length Byte Forward_Length Character*41 Directory 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 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' , 1 Default File = 'SYS$SYSTEM:.DAT', 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 Read( Unit=ScratchUnit, 1 KeyEQ=UserName, c 2 Err=99, 3 KeyID=0, 4 IOStat=Status) VMSMAIL_Record Call Priv_CLOSE (ScratchUnit) If (VMSMail_Record.Directory_Length.gt.0) Then i_brak = Index(VMSMail_Record.Directory,'[') Mail_Directory = Directory(:(BTrim(Directory)-1))// 1 VMSMail_Record.Directory 2 (i_brak+1:BTrim(VMSMail_Record.Directory)) Else Mail_Directory = Directory EndIf NewMes = VMSMail_Record.NewMail 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. 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 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=99, 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 = 19 csize = mailrec.rest(ptr:ptr+1) ptr = ptr + 2 from = mailrec.rest(ptr:ptr+size-1) if (index(from,you(:btrim(you))).gt.0) then ptr = ptr + size + 2 csize = mailrec.rest(ptr:ptr+1) ptr = ptr + 2 tousername = mailrec.rest(ptr:ptr+size-1) ptr = ptr + size + 2 csize = mailrec.rest(ptr:ptr+1) ptr = ptr + 2 subject = mailrec.rest(ptr:ptr+size-1) ptr = ptr + size +2 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) 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(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 '($JPIDEF)' Character Server*16, Port*12, Make_Pretty*70 Integer Session, Status, LAT_Info, colon Integer Privilege(2) /0,0/ External LAT_Info 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 I_Device(4) Byte B_Device(16), B_Device_Len Character C_Device*15 Equivalence (I_Device, B_Device) Equivalence (B_Device(1), B_Device_Len) Equivalence (B_Device(2), C_Device) Integer Lib$GetDVI External Lib$GetDVI Integer DVI$_TT_PhyDevNam/274/ Character Phy_Terminal*8 Integer L_Phy_Terminal 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 = '' ElseIf ( Terminal(1:2) .eq. 'LT' ) then Get_Location = 'Lat' c ** Site-Specific c Call routine to get LAT info colon = Index(terminal,':') terminal = terminal(1:colon) c Turn on CMKRNL privilege Privilege(1) = Prv$M_Cmkrnl Call Sys$Setprv(%Val(1),Privilege,,) c The LAT session number is returned also. You might find it useful. Status = LAT_info (Terminal(1:colon), Session, Server, 1 Port) c Turn off CMKRNL privilege Call Sys$Setprv(,Privilege,,) If (Status) then Server = Make_Pretty(Server) Port = Make_Pretty(Port) Get_Location = Server(1:8) // ' ' // Port(1:8) 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 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 = '' 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 = '' ! 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 .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 .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