C..Finger.For Callable finger routine C.. R. Garland / C.U.Chemistry Integer Function Finger(Command_line,Finger_Out_Routine,Access) 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 V5.0 or later C Must be installed with CMKRNL, SYSPRV, WORLD & OPER 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 OPER - so it can use TSM to query terminal servers. 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 (pre-V5) is at the end of this source. c c V50.1.00 Works with 5.0-1 with one exception-no one has c gotten TT_UCB to work, hence I NoOp'd it. For me this c is minor. Included is new load average driver support. c Both the Mail.mai and Vmsmail.dat sections were c rewritten to support v5 formats. LAT port and Queue c name code now uses documented interfaces. c By Rand P. Hall 11-Oct-1988 c V50.1.01 Mods at SPC - Fixed /HELP qualifier, fixed display c of unread mail when explicit mail directory is not c specified, widened location field to 25, changed dis- c play of unread mail slightly, display server and port c names without prettying. c By Terry Kennedy 02-Mar-1989 c V50.1.02 Mods at SPC - Fixed to not pretty up personal names, c also to not swap text when a comma is found in a per- c sonal name (messes up John X. Doe, Jr., for example). c By Terry Kennedy 08-Mar-1989 c V50.1.03 Mods at SPC - Fixed array-bounds problem in get_image c when image = DCL, convert null username to spaces for c NULL and SWAPPER PIDs (80, 81), fix ACCVIO on get_ c lastname when no personal name defined. c By Terry Kennedy 09-Mar-1989 c V50.1.04 Mods at SPC - Fixed array-bounds problems when null c line in planfile, finger @node with no parameters. c By Terry Kennedy 10-Mar-1989 c V50.1.05 Mods at SPC - Generate warning when sorting on an c unknown sort field, eliminate duplicate NONODE mes- c sages, use standard error message format throughout. c By Terry Kennedy 16-Mar-1989 c V51.1.06 Mods at SPC - More subscript fixes in DO_HELP, DEC- c NET_FINGER, send full help to remote fingerer via c jnet, reduce location to 24 columns. c By Terry Kennedy 18-Mar-1989 c V51.1.07 Mods at SPC - Fix finger/sort=login_time not working, c add /sort=cpu_time as a new option, add display of c VMS mail forwarding address. c By Terry Kennedy 26-Mar-1989 c V51.1.08 Mods at SPC - Merge in Frank Nagy's Fermilab mods. c By Terry Kennedy 13-Apr-1989 c V51.1.09 Mods at SPC - *FINALLY* fix the Jnet finger sort bug c (for good this time, I hope...), fixed some cosmetic c stuff when running as Jnet finger server. c By Terry Kennedy 15-Apr-1989 c V51.1.10 Mods at SPC - Strip '_' from VTA port names so that c _VTA1234: fits in display field, shorten location, c default to /TTType, get terminal type from VMS if c not in Finger Common Block or if FCB says "Unknown", c send help text back to DECnet fingerer instead of c writing it to the NETSERVER.LOG file. c By Terry Kennedy 19-Apr-1989 c V51.1.11 Mods at SPC - Add Frank Nagy's fix for null/blank c host name in FCB, add /IAM stuff to report mail cor- c rectly for net links, fix bug with uninitialized c mail records. c By Terry Kennedy 25-Apr-1989 c V51.1.12 Mods at SPC - Finish up /IAM stuff (now we need a c victim (er, person) to test it heavily. c By Terry Kennedy 27-Apr-1989 c V51.1.13 Mods at SPC - Fix /IAM in DECNET_FINGER to not add c it if in the middle of poor-man's routing. Thus, we c preserve the real originating node/user info. A c side effect of this also cures sending the 'unrec- c ognized qualifier' msg back to the originator when c traffic passed through a V51.1.12 node. c By Terry Kennedy 29-Apr-1989 c V51.1.14 Mods at SPC - change '.' to ',' in system_version, c fix stupid bug of image name being char*9 instead of c char*20 in FINGERSHO.FOR - how stupid... c By Terry Kennedy 06-Jun-1989 c V51.1.15 Mods at AAMRL - Can now determine idle times using c TERMINAL.MAR from Joe Meadows. c By Ted Nieland 12-Jun-1989 c V51.1.16 Mods at AAMRL - Allow for mail forwarding using PMDF's c DELIVER% and still show new mail count and messages. c By Ted Nieland 13-Jun-1989 c V51.1.17 Mods at SPC - Clean up /BYPASS processing so we don't c send blanks out instead, also handle the case where c more than one /BYPASS was specified on the command c line. c By Terry Kennedy 14-Jun-1989 c V51.1.18 Mods at SPC - Fix up the bug which caused mail for- c warding to not display in some (random) cases, try c again for the NONODE reporting problem - the previous c solution prevented reporting it to DECnet fingerers, c add display of RSCS spool file (jnet) count. c By Terry Kennedy 27-Jun-1989 c V51.1.19 Mods at SPC - Make qualifier operation totally de- c pendant on the CLD, make no assumptions about "de- c faults" here, add DISMAILREP, DISSUBJREP qualifiers c for sites who don't want the mail stuff, show process c type in terminal field if noninteractive (thanks to c Frank Nagy), add ability to finger terminal servers c (sort of). c By Terry Kennedy 01-Jul-1989 c V51.1.20 Mods at SPC - Change personal name field to be the c same size as in UAF so people's personal names don't c get truncated (why do bosses have the longest names?) c By Terry Kennedy 03-Jul-1989 c V51.1.21 Mods at SPC - Correct typo in optional /IAM code in c routine decnet_finger, fix get_image to return the c full image name even when not in 1st 64 bytes of the c image filespec, fix ACCVIO if prettying the personal c name is selected. Thanks, Lauri! Fix bug in "common c adm DECnet" code which wouldn't compile and wouldn't c find local mail, don't propagate /IAM's out onto the c RSCS (Bitnet) network, cosmetic corrections. c By Terry Kennedy 07-Aug-1989 c V51.1.22 Mods at SPC - Include Craig Watkins' fixes to speed c up ADD/USER/UAF in FINGMAINT, fix spurious error in c routine get_decnet_remote if the logical tables aren't c set up yet (from CRW and FJN), remove unused TTUCB c storage in FINGERCOM (from FJN), report dialups on c DECservers a little differently, add check for mail c privacy (Print nastygram if the fingeree's mail file c contains a folder named F_PRIVACY), fix 2 typos in c FINGERLAT, modify GET-IDLE for VMS V5.2. c By Terry Kennedy 02-Sep-1989 c V51.1.23 Mods at SPC - Fix DISSUBJREP, which was completely c broken (oops - thanks Lauri!), install temporary c workaround for Get_DECnet_Remote blowing up Finger c with "No logical name" (thanks, Glenn!). c By Terry Kennedy 17-May-1990 c V51.1.24 Mods at SPC - Fix an obscure looping condition. c By Terry Kennedy 20-Jan-1991 c V51.1.25 Mods at SPC - Support UCX remote user field, new c PMDF deliver format, keep a local copy of XABPRODEF c since DEC has broken the one in FORSYSDEF again. c By Terry Kennedy 11-Jun-1991 c V51.1.26 Mods at SPC - Add new terminal types to table, fix c potential array bound problem there as well. Outbound c UCX TCP/IP support. Correct long-standing problems c which caused nodenames illegal to DECnet to prevent c attempts over other transports. Correct problem with c defined (in FINGERSHR) but unknown nodes causing FIN- c ger to appear to die (exiting without printing any c error message). Increase size of node name from 12 to c 32 to accomodate TCP/IP hosts. Do TCP finger before c Jnet finger. c By Terry Kennedy 27-Aug-1991 c V51.1.27 Mods at SPC - Add FING_NOSERVICE to report "object un- c known at remote node" responses. c By Terry Kennedy 16-Nov-1991 c V51.1.28 Mods at SPC - Add support for Interconnections' TES c terminals (QTAn: devices), fix idle time code which c was broken for an indeterminate period of time. c By Terry Kennedy 12-Dec-1991 c V51.1.29 Mods at SPC - Fix undeclared/uninitialized updelta c variable which caused uptime in the daemon versions c to fluctuate wildly after the first invocation. c By Terry Kennedy 16-Jan-1992 c V51.1.30 Mods at SUNY at Buffalo c Modify Function Get_Location to add support for NT devices for c TCP/IP (telnet) logins. c Modify Function DECnet_Finger to allow for new error code c SS$_IVDEVNAM which is now given under OpenVMS AXP v1.5 when a c call is given to open a decnet connect to an IP style name. c By Leonardo J. Miceli 7-Mar-1994 c V51.1.31 Mods at SUNY at Buffalo c Modify Function DECnet_Finger to allow for new error code c SS$_IVNODNAM which is now given under OpenVMS AXP v6.1 when a c call is given to open a decnet connect to an IP style name. c By Leonardo J. Miceli 10-Aug-1994 c V51.1.32 Mods at SPC - Re-merge SPC-specific changes, remove c hardware type from banner line. *Finally* remove extra c blanks in date, user, load strings. Remove support for c terminal servers via TSM as it's been broken for ages. c By Terry Kennedy 5-Jul-2000 c V51.1.33 Mods at SPC - More blank removal (last login, new mail, c new RSCS files), fix garbled help sent over MultiNet c TCP connections. c By Terry Kennedy 7-Jul-2000 c V51.1.34 Mods at SPC - Yet more blank removal, fix up interact- c ive job count, change message to "No users logged in." c By Terry Kennedy 9-Jul-2000 c V51.1.35 Mods at SPC - Add non-interactive login since the POP c and IMAP servers update this when users check their c mail. c By Terry Kennedy 24-Jul-2000 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 V51.1.35 of 24-Jul-2000'/ Common /Version_Common/ VersionMsg Integer Privilege(2) /0,0/ Integer Btrim Logical Wild, Wild_Match Character Command_line*(*) Character Expanded_Command*132 Character Node*32, Next_Node*32 Character Get_Node*32, Save_Node*32 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 External Fing_NoService External Fing_Unreachable Integer Access Integer Local_Finger, 1 Remote_Finger Integer TRN_ItemList(4) Integer*2 TRN_ItemList2(8) Equivalence (TRN_ItemList, TRN_ItemList2) Integer TRN$_String /Z00000002/ Character DECnet_Node*32, My_Node*32 Integer l_Node Integer SS$_Status Integer Sys$TrnLnm External SS$_NoTran 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), 1 Finger_Out_Routine,Access) ! 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.) 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 'SYS$NODE', 1, TRN_ItemList) If ( SS$_Status .eq. %Loc(SS$_Notran)) Then My_Node = 'Finger' Else My_Node = DECnet_Node(:L_Node-2) Endif C Format command c Avoid subscript errors - tmk if (i_AT+l_Save_Node .eq. l_Com) Then Expanded_Command = Command_line(:i_AT-1)// 1 Route(:Btrim(Route)) else Expanded_Command = Command_line(:i_AT-1)// 1 Route(:Btrim(Route))// 2 Command_line(i_AT+l_Save_Node+1:l_Com) end if C send command out to appropriate network/node If ((wild .eq. .false.) .or. (Node_Type .ne. 'X')) Then Finger = Remote_Finger(Next_Node(:Btrim(Next_Node)), 1 Expanded_Command(:Btrim(Expanded_Command)), 2 Finger_Out_Routine, Node_Type, Access) EndIf c Test - report link failed if fing_noservice or fing_unreachable If (Finger.eq.%Loc(Fing_NoService) .or. 1 Finger.eq.%Loc(Fing_Unreachable) ) then Call Finger_Out_Routine(': link failed]'//CR//LF) End if c If a wild card net and node not found, see if there is a default router c bug? If ( Node_Type.eq.'*' .and. Finger.eq.%Loc(Fing_NoNode) ) then If (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 If ( Next_Node .eq. My_Node ) then ! I _am_ the router 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, Access) End if 200 Continue End do C Done Return End c------------------------------------------------------------------------ Integer Function Remote_Finger(Next_Node, Command, 1 Finger_Out_Routine, Node_Type, Access) Character Command*(*) Character Next_Node*(*) Character Node_Type*1 Character Flush/255/ Integer Access 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,Access) 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, Access) 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 .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 c If (Node_Type .eq. 'X') then c Remote_Finger = LAT_Finger(Next_Node, Finger_Out_Routine) c Return c EndIf If ( WildNet .and. NoNode ) then Remote_Finger = %Loc(Fing_NoNode) Else Remote_Finger = %Loc(Fing_NoNet) End if Return End c------------------------------------------------------------------------ Character*32 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' else If ( Net_Type .eq. 'X' ) then Get_Network = 'LAT' 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, Access) 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 '($RMSDEF)' Include '($SSDEF)' Include 'GETJPIDEF.FOR' c ** Site-Specific ** needed for BYPASS logic COMMON /BCZCOM/ FLAG_BYPASS LOGICAL FLAG_BYPASS c end of bypass logic 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 Integer SS$_Status Integer Sys$TrnLnm c Integer SS$_NOSUCHNODE /Z028C/ c Integer SS$_DEVNOTMOUNT /Z007C/ c Integer SS$_IVDEVNAM /Z0144/ c Integer SS$_NOSUCHOBJ /8356/ Integer TRN_ItemList(4) Integer*2 TRN_ItemList2(8) Equivalence (TRN_ItemList, TRN_ItemList2) Integer TRN$_String /Z00000002/ Character LocalQualifier*32, DECnet_Node*32 Integer l_Node Integer Access External Finger_Out_Routine External Fing_Complete, Fing_Abort External Fing_NoNode, Fing_NoNet External Fing_NoService External OutLink_UserOpen c Default return status DECnet_Finger = %Loc(Fing_Complete) c Construct the /IAM stuff c First the username... 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,,,) c ...then the nodename... 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 'SYS$NODE', 1, TRN_ItemList) c ...Now glue it together... LocalQualifier = '/IAM="'//UserName(:Btrim(UserName))//'~' 1 //DECnet_Node(:L_Node-2)//'"' 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 ( OutLinkOpenStatus .eq. SS$_IVDEVNAM ) then DECnet_Finger = %Loc(Fing_NoNode) Return End if If ( OutLinkOpenStatus .eq. SS$_IVNODNAM ) then DECnet_Finger = %Loc(Fing_NoNode) Return End if If ( OutLinkOpenStatus .eq. SS$_NOSUCHOBJ ) then DECnet_Finger = %Loc(Fing_NoService) 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. RMS$_SYN ) 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 151 IBCZ=INDEX(NET_COMMAND,'/BY') IF(IBCZ.eq.0) goto 152 IIBCZ=LEN(NET_COMMAND) IBCZEND=INDEX(NET_COMMAND(IBCZ+1:IIBCZ),'/') IF(IBCZEND.EQ.0) IBCZEND=INDEX(NET_COMMAND(IBCZ+1:IIBCZ),' ') IF(IBCZEND.EQ.0) THEN IBCZEND=IIBCZ+1 ELSE IBCZEND=IBCZEND+IBCZ ENDIF If (ibczend .gt. iibcz) Then net_command = net_command(:ibcz-1) Else net_command = net_command(:ibcz-1)// 1 net_command(ibczend:iibcz)//NUL EndIf FLAG_BYPASS = .TRUE. Goto 151 c end of bypass logic c !** Site-specific - If you will be fingering DECnet nodes running V4 of c finger, you may wish to select the version below which does not send the c /IAM qualifier (which will return a harmless error message when sent to c these old versions of finger). c !** Site-specific: Uncomment *this* for /IAM... c Ship command out, tacking on /IAM stuff if we are the originating node 152 If (Access .eq. 1) Then Write(OutboundLinkUnit,1002) 1 Net_Command(:Btrim(Net_Command))//LocalQualifier//CR//LF Else Write(OutboundLinkUnit,1002) 1 Net_Command(:Btrim(Net_Command))//CR//LF EndIf c !** Site-specific: ... Or *this* for no /IAM c Ship command out c152 Write(OutboundLinkUnit,1002) c 1 Net_Command(:Btrim(Net_Command))//CR//LF C Read response from network DoWhile(.true.) C ** Site-Specific C uncomment next for bypass logic IF (.NOT.FLAG_BYPASS) THEN do ibcz=1,il if(line(ibcz:ibcz).lt.' ')then iibcz=ichar(line(ibcz:ibcz)) if(iibcz.ne.9.and.iibcz.ne.10 1 .and.iibcz.ne.13)line(ibcz:ibcz)='.' endif enddo ENDIF c end of bypass logic 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 If (nl*80+1 .le. il) then Call Finger_Out_Routine(Line(nl*80+1:il)) Endif 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:01:00.00'/ Character Timeout*13 /'0 00:00:20.00'/ Integer InitialTime(2) Integer DeltaTime(2) Character CR /13/, LF /10/, Flush/255/, NUL/0/ 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 upcase the node name next_node=str$upcase(next_node) 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 c First, remove any present /IAM information from the RSCS command line Ibcz=Index(Net_Command,'/IAM=') If (ibcz .eq. 0) Goto 152 Iibcz=Len(Net_Command) Ibczend=Index(Net_Command(Ibcz+1:Iibcz),'/') If (Ibczend .eq. 0) Ibczend=Index(Net_Command(Ibcz+1:Iibcz),' ') If (Ibczend .eq. 0) Then Ibczend=Iibcz+1 Else Ibczend=Ibczend+Ibcz EndIf If (Ibczend .gt. Iibcz) Then Net_Command = Net_Command(:Ibcz-1) Else Net_Command = Net_Command(:Ibcz-1)// 1 Net_Command(Ibczend:Iibcz)//NUL EndIf c end of logic to remove /IAM stuff from RSCS commands 152 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-E-NETERR, 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-E-TMO, timeout for node '// 2 Next_Node//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,Access) Character VersionMsg*51 Common /Version_Common/ VersionMsg External Finger_Out_Routine Integer Access Character Command*(*) Character Name*31, Get_PersonalName*31 Character Make_Pretty*31 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/ Logical Wild_Parse Integer NonWild C ! site-specific: Set minimum non-wildcard characters if wildcards C are present in the username Parameter Minimum_NonWild = 3 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) c uai_list(2).endlist = uai$c_listend uai_list(2).endlist = 0 c Set default return status Local_Finger = %Loc(Fing_Complete) c initialize a few things l_Com = Len(Command) C Parse command Call Parse_Finger_Command(Command(:l_Com),ComName, 1 TestName,TestOutput,Finger_Out_Routine, 2 Access) c Print version if required If ( (TestOutput.and.FlagVersion) .ne. 0 ) Then Call Finger_Out_Routine(LF//VersionMsg//CR) EndIf c Check for wildcards in username If ( TestName .and. Wild_Parse( ComName, NonWild) ) Then If ( NonWild .lt. Minimum_NonWild ) Then Call Finger_Out_Routine(LF//'%FINGER-E-WILD, too few'// 1 ' non-wild characters in username '//CR//LF// 2 ' \'//ComName(:Btrim(ComName))//'\'//CR) Local_Finger = %Loc(Fing_Abort) Return EndIf EndIf c Output HELP if required If ( (TestOutput.and.FlagHelp) .ne. 0 ) Then Call Header_Brief(Finger_Out_Routine) c The MultiNet server doesn't distinguish between local and TCP modes, and c lbr$output_help doesn't like having output sent over a TCP connection, so c the server_finger.com file adds a qualifier of /nethelp to let us dis- c tinguish between a local help request and a TCP help request. If ((Access .eq. 2) .or. (Access .eq. 3) .or. 1 ((TestOutput.and.FlagNetHelp) .ne. 0)) then LbrFunc = Lbr$C_Read ii = Lbr$Ini_Control(LbrIndex,LbrFunc) If ( .not. ii ) then ii_stat1 = ii Call Lib$Signal(%Val(ii_stat1)) Local_Finger = %Loc(Fing_Abort) Return End if c ! Site-specific: You may change the help library name below (also see c one other location below). ii = Lbr$Open(LbrIndex,'SYS$HELP:HELPLIB.HLB') If ( .not. ii ) then ii_stat2 = ii Call Lib$Signal(%Val(ii_stat2)) Call Lbr$Close(LbrIndex) Local_Finger = %Loc(Fing_Abort) Return End if ii = Lbr$Get_Help(LbrIndex,,Do_Help, 1 Finger_Out_Routine,'FINGER...') If ( .not. ii ) then ii_stat3 = ii Call Lib$Signal(%Val(ii_stat3)) Call Lbr$Close(LbrIndex) Local_Finger = %Loc(Fing_Abort) Return End if Call Finger_Out_Routine(LF) Call Lbr$Close(LbrIndex) Else If (Access .eq. 1) then ii = Lbr$output_help( lib$put_output,,'FINGER', c ! Site-specific: You may change the help library name below (also see c one other location above). 1 'SYS$HELP:HELPLIB',, lib$get_input) Else Call Finger_Out_Routine(LF//'%FINGER-W-UKNMODE, unknown access' 1 //' mode.'//CR) Endif Endif If (.not.ii) call exit(ii) Return EndIf LoggedIn = .False. 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,,) c Issue a dummy call to reset the index for jnet versions Call Make_Info(0,STS,Prcnam,Username,Terminal, 1 State, GPgCnt+PPgCnt,HeaderWritten, 2 TestOutput,FlagProcess) 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 users logged in.') 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 c ! Site-specific: Uncomment next line to pretty up usernames - note that c this will destroy things like McDonald. Also note this in two more places. c 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,Access) EndIf C 1 last line-feed at end Call Finger_Out_Routine(LF) Return 1000 Format(A) END c--------------------------------------------------------------------------- Subroutine Parse_Finger_Command(Command,ComName, 1 TestName,TestOutput,Finger_Out_Routine, 2 Access) 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 COMMON /BCZCOM/ FLAG_BYPASS LOGICAL FLAG_BYPASS c end of bypass logic Character Command*(*), ComName*12 Character CR /13/, LF /10/, NUL/0/, SP/' '/ Logical TestName Integer TestOutput External FingerCli_Table External Finger_Out_Routine Integer Access Integer Cli$Dcl_Parse, Cli$Get_Value, Cli$Present Integer Kludge_Cli$Dcl_Parse, SortField, l_SortType Integer Btrim, l_WhoAmI Character CCC*8, SortType*20, WhoAmI*32 Common /Sorter/ SortType, SortField, WhoAmI, l_WhoAmI Character Str$UpCase*32 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. c Check for the /IAM qualifier before trying JPI, but only on jnet or DECnet If ( (Access .eq. 2) .or. (Access .eq. 3)) Then If ( Cli$Present('IAM') ) Then TestOutput = TestOutput .or. FlagIAM Call Cli$Get_Value('IAM', WhoAmI) l_WhoAmI = Btrim(WhoAmI) WhoAmI = Str$UpCase(WhoAmI) If ( ComName .eq. '.' ) 1 ComName = WhoAmI(2:Index(WhoAmI,'~')-1) EndIf Endif 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('NETHELP') ) 1 TestOutput = TestOutput .or. FlagNetHelp If ( Cli$Present('HELP') ) 1 TestOutput = TestOutput .or. FlagHelp C ** Site-Specific C uncomment next for bypass switch FLAG_BYPASS = .FALSE. ! BCZ If ( Cli$Present('BYPASS') ) ! BCZ 1 FLAG_BYPASS = .TRUE. ! BCZ c end of bypass logic c If nothing else on, turn on FlagInteractive. Note this is a last-chance c trap, the defaults should be changed by editing the .CLD file. If ( TestOutput .eq. 0 ) 1 TestOutput = FlagInteractive 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 If (index('CPU_TIME', SortType(:l_SortType)) .eq. 1) then SortField = 7 Else If ((l_SortType .eq. 1) .and. (SortType(1:1) .eq. SP)) then SortType = 'Default' SortField = 1 Else Call Finger_Out_Routine(LF//'%FINGER-W-UKNSRT, unknown sort ' 1 //'field '//CR//LF//' \'// 2 SortType(:l_SortType)//'\'//CR) SortType = 'Default' SortField = 1 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 If ( Cli$Present('AREA') ) 1 TestOutput = TestOutput .or. FlagArea If ( Cli$Present('DISSUBJREP') ) 1 TestOutput = TestOutput .or. FlagDisSubj 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 test for /FULL, it turns all displays on If ( Cli$Present('FULL') ) 1 TestOutput = TestOutput .or. FlagFull c test for /DISMAILREP, it forces mail display off If ( Cli$Present('DISMAILREP') ) 1 TestOutput = TestOutput .and. not(FlagMail) 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) If (l_Line .gt. 0) then Call Out_Routine(LF//Space(:5*(Level-1)+1)//Line(:l_Line)//CR) Else Call Out_Routine(LF//Space(:5*(Level-1)+1)//CR) Endif 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 If ( GRP .le. SysGRP ) 1 FlagProcess = FlagProcess .or. FlagSystem ElseIf ( Owner .ne. 0 ) Then FlagProcess = FlagProcess .or. FlagSubprocess If ( GRP .le. SysGRP ) 1 FlagProcess = FlagProcess .or. FlagSystem 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 '($prdef)' 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 External SS$_NoTran 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*32 CPU_Type Integer l_CPU, l_Vrsn Character System_Version*8 Character Node*32 Character AscTime*23, AscSince*23, Make_Pretty*23 Integer BegTime, BegSince Character AscDelsince*23 ! gce retrofit Character Day_OfTheWeek*9, Today*9, Upday*9 Character MsgLine*132 Real Load1, load5, load15 External Sys$gl_IJobCnt External Sys$gl_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), UpDelta(2) Character NUL/0/, LF/10/, CR /13/, SP /' '/ Character Temp*25 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$_hw_name syi_list(1).bufferaddr = %loc(CPU_Type) syi_list(1).bufferlen = len(CPU_Type) syi_list(1).lengthaddr = %loc(L_cpu) 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) C If (CPU_Type(1:1).eq.'V') CPU_Type(1:1) = ' ' c More fixing of CPU type - strip off "COMPAQ" and "Alphaserver" If (CPU_Type(1:7) .eq. 'COMPAQ ') Then CPU_Type = CPU_Type(8:L_cpu) Endif If (CPU_Type(1:12) .eq. 'AlphaServer ') Then CPU_Type = CPU_Type(13:L_cpu) Endif c Fix up the CPU type, replace "MicroVAX " by "uVAX-", "VAXstation " by c "VS-" and "VAXserver" by "Vs-" If (CPU_Type(1:9) .eq. 'MicroVAX ') Then CPU_Type = 'VAX-' // CPU_Type(10:L_cpu) ElseIf (CPU_Type(1:11) .eq. 'VAXstation ') Then CPU_Type = 'VS-' // CPU_Type(12:L_cpu) ElseIf (CPU_Type(1:10) .eq. 'VAXserver ') Then CPU_Type = 'Vs-' // CPU_Type(11:L_cpu) Endif Call Str$Trim( CPU_Type, CPU_Type, L_cpu) If ( CPU_Type(L_cpu-5:L_cpu) .eq. 'Series') Then L_cpu = L_cpu - 6 c If (CPU_Type(L_cpu-1:L_cpu) .eq. '00') c 1 CPU_Type(L_cpu-1:L_cpu) - 'xx' EndIf Call Str$Trim( CPU_Type, CPU_Type(1:L_cpu), L_cpu) 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 'SYS$NODE', 1, TRN_ItemList) If (( Net$C_Local_Host_Name(1:1) .eq. ' ' ) .OR. 1 ( Net$C_Local_Host_Name(1:1) .eq. NUL)) Then If ( SS$_Status .eq. %LOC(SS$_Notran) ) 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) BegTime = 1 If (AscTime(1:1) .eq. ' ') Then BegTime = 2 Endif Today = Day_OfTheWeek(%Val(0)) UpTime(1) = 0 UpTime(2) = 0 UpTime(1) = Get_l_Val(Exe$gl_AbsTim) ! up time (sec) UpDelta(1) = 0 UpDelta(2) = 0 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) BegSince = 1 If (AscSince(1:1) .eq. ' ') Then BegSince = 2 Endif 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$gl_IJobCnt) ! # users c for some unknown reason, Alpha VMS reports one more job than actually c exists on all systems I've seen If (Ijobs .gt. 0) Then Ijobs = Ijobs - 1 Endif Bjobs = Get_w_Val(Sys$gl_BJobCnt) ! # batch c ! Site-specific: This is the load average pseudo-device. If not c available, omit this section. Or leave it and it will still be OK. Open(Unit=ScratchUnit, 1 File=LoadDevice, 2 Type='NEW', 3 RecordSize=36, 4 Err=101) Read(ScratchUnit,2000,Err=101) Load1, Load5, Load15 Close(Unit=ScratchUnit) LoadAvailable = .true. 101 Continue C Print full header C Organization name if defined If ( Net$C_Organization .ne. ' ' ) 1 Call Finger_Out_Routine( 2 LF// 3 Net$C_Organization(:BTrim(Net$C_Organization))// 4 CR) C 1st full line Call Finger_Out_Routine(LF// 1 Node(:l_Node)//' '// 2 CPU_Type(:Btrim(CPU_Type))//', '// 4 'VMS '// 5 System_Version(:Btrim(System_Version))// 6 ', '// 7 Today(:Btrim(Today))//', '// 8 AscTime(BegTime:17)//', ') Write(Temp,1003) Ijobs ij_nospace = 1 do while (Temp(ij_nospace:ij_nospace) .eq. ' ') ij_nospace = ij_nospace + 1 end do Call Finger_Out_Routine(Temp(ij_nospace:4)) If ( Ijobs .eq. 1 ) then Call Finger_Out_Routine(' User, ') Else Call Finger_Out_Routine(' Users, ') End if Write(Temp,1003) Bjobs ib_nospace = 1 do while (Temp(ib_nospace:ib_nospace) .eq. ' ') ib_nospace = ib_nospace + 1 end do Call Finger_Out_Routine(Temp(ib_nospace:4)//' Batch') 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(BegSince:17)) If ( LoadAvailable ) Then Write(Temp,1002) Load1 ij_nospace = 1 do while (Temp(ij_nospace:ij_nospace) .eq. ' ') ij_nospace = ij_nospace + 1 end do Call Finger_Out_Routine(', Load: '//Temp(ij_nospace:5)) Write(Temp,1002) Load5 ij_nospace = 1 do while (Temp(ij_nospace:ij_nospace) .eq. ' ') ij_nospace = ij_nospace + 1 end do Call Finger_Out_Routine(' '//Temp(ij_nospace:5)) Write(Temp,1002) Load15 ij_nospace = 1 do while (Temp(ij_nospace:ij_nospace) .eq. ' ') ij_nospace = ij_nospace + 1 end do Call Finger_Out_Routine(' '//Temp(ij_nospace:5)) 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 1002 Format(F5.2) 1003 Format(I4) 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 External SS$_NoTran Integer Sys$AscTim, Sys$GetTim, Sys$TrnLnm Integer Btrim Character Node*9 Character Day_OfTheWeek*9, Today*9 Character AscTime*23, Make_Pretty*23 Integer BegTime 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 'SYS$NODE', 1, TRN_ItemList) If (( Net$C_Local_Host_Name(1:1) .eq. ' ' ) .OR. 1 ( Net$C_Local_Host_Name(1:1) .eq. NUL)) Then If ( SS$_Status .eq. %LOC( SS$_Notran) ) 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) BegTime = 1 If (AscTime(1:1) .eq. ' ') Then BegTime = 2 Endif 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(BegTime: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*31, Filter_Control_Chars*15 Character Name*31, Get_PersonalName*31 Character Image*20, Get_Image*20 Character Time_String*11, Login_Time*5 Character CPU_Time*6, Idle_Time*5, Get_Idle*5 Character TTType*25, TermOrType*8 Character Quename*18 Character CR /13/, LF /10/, NUL /0/ Integer PgCnt Character*5 States(15) / 1 'ColPg','MWait',' CEF ',' PFW ',' LEF ',' LEFO',' Hib ', 1 ' HibO',' Susp','SuspO',' FPg ',' Com ',' ComO',' Cur ', 1 ' '/ Integer LEF_State /5/, Blank_State /15/ Integer State_COMO /13/, State_HIBO /8/ Integer State_LEFO /6/, State_SUSPO /10/ Character*5 Size Logical HeaderWritten Integer Privilege(2) /0,0/ character*31 get_queue, queue_name c ! site-specific c Note - this routine is set up so you can select the information c you desire printed. Set the defaults for your site in the FINGERCLI.CLD c file. The user can override these with explicit qualifiers to the c FINGER command. If all fields are selected the line is 135 characters long c (3 more for long terminal line number). You could vary the size of certain c fields (e.g. PERSONALNAME or LOCATION) if you wanted to customize things c further. I use only 15 out of 25 characters of the location, and the TTType c may wrap. The size of these could be varied. I would never use certain c combinations together, e.g. PROCESSNAME and USERNAME (they are practically c redundant) - but to each his own. (USERNAME is useful for MAIL and PHONE, c PROCESSNAME is unique.) - Rg c first some petty preprocessing If ( (Testoutput.and.FlagPID) .ne. 0 ) then Write(PID_String,1001) PID Do II = 1,8 If ( PID_String(II:II) .eq. ' ') PID_String(II:II) = '0' End do End if Call NULToSP(Terminal,8) If ( (Testoutput.and.FlagProcessname) .ne. 0 ) then Call NULToSP(Prcnam,15) Prcnam = Filter_Control_Chars(Prcnam) End if If ( Username(1:1) .eq. NUL ) Then If ( Prcnam(1:4) .eq. 'NULL' ) Then Username = '' Else If ( Prcnam(1:7) .eq. 'SWAPPER' ) Then Username = '' Else Username = ' ' EndIf EndIf If ( (Testoutput.and.FlagPersonalName) .ne. 0 ) c ! site-specifc: choose one of the two following lines 1 Name = Get_PersonalName(Username) c 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 = ' --- ' Write(Size,1003) PgCnt Location = Get_Location(Terminal,TTType,PID) c If not an interactive process, replace terminal by process type TermOrType = Terminal If ( (FlagProcess .and. FlagBatch) .ne. 0 ) Then TermOrType = 'Batch' TTType = ' ' ElseIf ( (FlagProcess .and. FlagNetwork) .ne. 0 ) Then TermOrType = 'Network' TTType = ' ' ElseIf ( (FlagProcess .and. FlagSubProcess) .ne. 0 ) Then TermOrType = 'Subproc' TTType = ' ' ElseIf ( (FlagProcess .and. FlagSystem) .ne. 0 ) Then TermOrType = 'System' TTType = ' ' ElseIf ( TermOrType .eq. ' ' ) Then TermOrType = 'Detach' TTType = ' ' EndIf c Turn on CMKRNL privilege Privilege(1) = Prv$M_Cmkrnl Call Sys$Setprv(%Val(1),Privilege,,) If ( (Testoutput.and.FlagIdleTime) .ne. 0 ) 1 Idle_Time = Get_Idle(Terminal) c Turn off CMKRNL privilege Call Sys$Setprv(,Privilege,,) If ( (FlagProcess.and.FlagSubprocess) .ne. 0 ) then Location = '- Subprocess -' TTType = ' ' Else If ( (STS.and.Pcb$m_Batch) .ne. 0 ) Then c Turn on SYSPRV privilege Privilege(1) = Prv$M_Sysprv Call Sys$Setprv(%Val(1),Privilege,,) c get job controller information queue_name = get_queue(pid) c Turn off SYSPRV privilege Call Sys$Setprv(,Privilege,,) If (queue_name .eq. ' ') Then Location = 'Q.' Else Location = 'Q.'//queue_name EndIf 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(1:20)//' ') If ( (Testoutput.and.FlagImagename) .ne. 0 ) c ** Site-Specific - length of image field (also do the header above...) 1 Call Finger_Out_Routine(Image(1:9)//' ') If ( (Testoutput.and.FlagTerminal) .ne. 0 ) c 1 Call Finger_Out_Routine(TermOrType(1:4)//' ') ! short 1 Call Finger_Out_Routine(TermOrType(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:16)//' ') If ( (Testoutput.and.FlagTTType) .ne. 0 ) 1 Call Finger_Out_Routine(TTType(1:8)) 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, Access) c Routine to type a user's Mail info and PLAN file, given his name. c Adapted from routine "Type_Plan" written at CMU PSYA:: c ! Site-specific note: If you want different names for plan files, c change or add to the following list Include 'Fingerdef.inc' Include 'Finger_Context' Include 'FingerFlg' Include '($FORIOSDEF)' c ** Site-Specific c uncomment for BYPASS switch logic COMMON /BCZCOM/ FLAG_BYPASS LOGICAL FLAG_BYPASS c end of bypass logic Parameter PlanFileName1 = 'FINGER.PLN' Parameter PlanFileName2 = 'PLAN.' ! compatible with EUNICE c Parameter PlanFileName3 = 'anything' ! your choice External Finger_Out_Routine Integer Access Integer ii, FindCount, FindContext Character FindTemplate*64, FindResult*64 Integer RMS$_Normal/65537/ 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 UAF_Flags Equivalence (UAF_Flags, UAF_Record(UAF$L_Flags)) Integer LastLogin(2), UAF_LastLogin(2) Equivalence (UAF_LastLogin,UAF_Record(UAF$Q_LastLogin_I)) Integer LastLoginN(2), UAF_LastLoginN(2) Equivalence (UAF_LastLoginN,UAF_Record(UAF$Q_LastLogin_N)) Integer*2 NewMes c add longword UIC value also Integer*4 UICval Equivalence (UICval,UAF_Record(UAF$K_UIC)) Structure /VMSMAIL_Structure/ union map byte rec(2048) end map map Character crec*2048 end map end union End Structure Record /VMSMAIL_Structure/ VMSMail_Record Structure /MAIL_Structure/ union map character rec*3047 end map map integer*2 date(4) character %fill(1) character folder*39 union map character rest*3000 end map map integer*2 irest(1500) end map end union end map end union End Structure structure /itmlist/ union map integer*2 bufferlen integer*2 itemcode integer*4 bufferaddr integer*4 lengthaddr end map map integer*4 endlist end map end union end structure include '($jpidef)' integer sys$getjpiw character you*12 Character SortType*20, WhoAmI*32 Integer SortField, l_WhoAmI Common /Sorter/ SortType, SortField, WhoAmI, l_WhoAmI Integer FoundSender, Erase Character*12 F_User Character*32 F_Node Character*32 F_ByAt Character*32 F_ByColon Character*80 UpFrom Character Str$UpCase*256 Character*64 Directory Character*128 Mail_Directory Logical Captive Logical LoggedIn Integer Status Integer SS$_Status Character Temp*32, Sender*40 Character*50 MailFile, PlanFile Character*12 UserName Character*9 Day_oftheWeek, LastLogin_Day, Mail_Day Character*70 LastLogin_Time, Make_Pretty Integer BegTime Integer ij_nospace Character*17 Mail_Time Character*132 Line Character*1 LF/10/, CR/13/, NUL/0/ Integer Btrim, Sender_len Integer TestOutput Integer*4 UserUIC,FlgUIC Common/UseUIC/UserUIC,FlgUIC External Priv_UserOpen logical foundmail character subject*80,csize*2,tousername*12,from*80 integer size*2, ptr equivalence (size,csize) record /itmlist/ jpi_itmlist(2) Record /MAIL_Structure/ mailrec character maildir*256,cfn*2,cfnlen*2, 1 cnewmes*2,fwdinfo*256 integer fn*2, fnlen*2 logical got_newmes, got_dir, got_subj, got_fwd equivalence (cfn,fn) equivalence (cfnlen,fnlen) equivalence (cnewmes,newmes) c First get stuff from UAF c open the UAF FlgUIC=0 c FlgUIC=0 to tell priv_useropen not to bother with UIC Open(Unit=UafUnit, 1 File = 'SYSUAF', 2 Default File = 'SYS$SYSTEM:.DAT', 2 Err=999, 3 User Open = Priv_UserOpen, 4 Status = 'Old', 5 Organization = 'Indexed', 6 Access = 'Keyed', 7 Form = 'Formatted', 8 Readonly, 9 Shared) c read it Read(UafUnit,1000,KeyEq=UserName,Err=999) UAF_Record c close it Call Priv_Close(UafUnit) c Concatenate the DEFDEV and DEFDIR into one string Directory. Directory = UAF_DefDev(:UAF_L_DefDev) // 1 UAF_DefDir(:UAF_L_DefDir) c set up the last login stuff LastLogin(1) = UAF_LastLogin(1) LastLogin(2) = UAF_LastLogin(2) LastLoginN(1) = UAF_LastLoginN(1) LastLoginN(2) = UAF_LastLoginN(2) Captive = BTEST(UAF_Flags, UAF$V_Captive) c Save owner UIC UserUIC = UICval Call Finger_Out_Routine(LF//CR) C Login device/directory information If ( (TestOutput .and. FlagArea) .ne. 0 ) Then If (Captive) Then Call Finger_Out_Routine(LF//' Captive user account.') Else Call Finger_Out_Routine(LF//' Default directory: '// 1 Directory(:Btrim(Directory))) EndIf Call Finger_Out_Routine(CR) EndIf 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) BegTime = 1 If (LastLogin_Time(1:1) .eq. ' ') Then BegTime = 2 Endif If ( LoggedIn ) then Call Finger_Out_Routine(LF//' Logged in since: ') Else Call Finger_Out_Routine(LF//' Last interactive login: ') End if Call Finger_Out_Routine( 1 LastLogin_Day(:Btrim(LastLogin_Day))//', '// 2 LastLogin_Time(BegTime:17)//CR) End if C and non-interactive If ( .not. (LastLoginN(1).eq.0 .and. LastLoginN(2).eq.0) ) then LastLogin_Day = Day_oftheWeek(LastLoginN) Call Sys$AscTim(,LastLogin_Time,LastLoginN,) LastLogin_Time = Make_Pretty(LastLogin_Time) BegTime = 1 If (LastLogin_Time(1:1) .eq. ' ') Then BegTime = 2 Endif Call Finger_Out_Routine(LF//' Last non-interactive login: ') Call Finger_Out_Routine( 1 LastLogin_Day(:Btrim(LastLogin_Day))//', '// 2 LastLogin_Time(BegTime:17)//CR) End if C Mail information c !** Site-specific - If you don't want to display any mail information, c edit the .CLD file and add the keyword ', Default' to the DISMAILREP c qualifier. However, DISSUBJREP should be adequate for most cases - see c later items in this source file (search for DISSUBJREP). If ( (TestOutput.and.FlagMail) .ne. 0 ) then c Now get VMSMAIL stuff (system-wide data) Open ( Unit=ScratchUnit, 1 File='VMSMAIL_PROFILE' , 1 Default File = 'SYS$SYSTEM:.DATA', 1 Err = 99, 1 UserOpen = Priv_UserOpen, 2 Status='Old' , 3 Organization='Indexed' , 4 Access='Keyed' , 5 Form='Unformatted' , 7 Readonly , 8 Shared , 1 RecordType='Variable' ) c newmes=0 got_newmes=.false. got_dir=.false. got_fwd=.false. maildir=' ' fwdinfo=' ' ptr=32 fn=1 !non-zero c Clear the mail record Do Erase = 1, 2048 vmsmail_record.crec(Erase:Erase) = NUL EndDo Read( Unit=ScratchUnit, 1 KeyEQ=UserName, c 2 Err=99, 3 KeyID=0, 4 IOStat=Status) VMSMAIL_Record c if (status.eq.36) goto 99 if (status.eq.FOR$IOS_ATTACCNON) goto 99 Call Priv_CLOSE (ScratchUnit) c c [rph] see VMSPROFILE_DATA.format for the struture of these records c do while ((.not.(got_newmes.and.got_dir.and.got_fwd)) 1 .and.(fn.ne.0)) cfn=vmsmail_record.crec(ptr:ptr+1) cfnlen=vmsmail_record.crec(ptr+2:ptr+3) if (fn.eq.1) then cnewmes=vmsmail_record.crec(ptr+4:ptr+5) got_newmes=.true. else if (fn.eq.3) then maildir=vmsmail_record.crec(ptr+4:ptr+4+fnlen-1) got_dir=.true. else if (fn.eq.4) then fwdinfo=vmsmail_record.crec(ptr+4:ptr+4+fnlen-1) got_fwd=.true. end if ptr=ptr+4+fnlen end do c**** Campus Mail? If ((got_fwd .eq. .true.) .and. 1 (index(Str$UpCase(fwdinfo(:btrim(fwdinfo))),'CAMPUS-MAIL.SPC.EDU') 2 .ne. 0)) Then Call Finger_Out_Routine(LF//' Mail is forwarded to: '// 1 'Campus Mail (Hardcopy)'//CR) Go To 99 Endif If ((got_fwd .eq. .true.) .and. 1 (index(Str$UpCase(fwdinfo(:btrim(fwdinfo))),'DELIVER%') 2 .eq. 0)) Then If (index(Str$UpCase(fwdinfo(:btrim(fwdinfo))),'IN%"~') .eq. 0) Then Call Finger_Out_Routine(LF//' Mail is forwarded to: '// 1 fwdinfo(:BTrim(fwdinfo))//CR) Go To 99 EndIf Endif c**** If (NewMes .gt. 0) then If (maildir(1:1) .eq. '[') Then i_brak = Index(maildir,'[') Mail_Directory = Directory(:(BTrim(Directory)-1))// 1 maildir(i_brak+1:BTrim(maildir)) Else Mail_Directory = Directory EndIf c ! Site-specific note: c If you do not wish the mail "From: so-and-so" information printed c edit the .CLD file and set the DISSUBJREP qualifier 'Default' c This section contributed by Todd Aven of U. of Mariland c Hacked up by yours truly. Rg c Now includes Subject [rph] and pretty much a re-hack job c for v5 [rph] another complete re-hack, the mail file format is similar c to vmsmail_profile.data (q.v.) c MailFile = Mail_Directory(:Btrim(Mail_Directory))// 1 'MAIL.MAI' Open ( Unit=ScratchUnit, 1 File=MailFile , 2 Status='Old' , 3 User Open = Priv_UserOpen, 4 Form='Formatted' , 5 Readonly , 6 Shared , 7 Err=100, 8 Record Type='Variable', 9 Organization='Indexed', 1 Access='Keyed') mailrec.rec = ' ' jpi_itmlist(1).bufferlen=12 jpi_itmlist(1).itemcode=jpi$_username jpi_itmlist(1).bufferaddr=%loc(you) jpi_itmlist(2).endlist=jpi$c_listend call sys$getjpiw(,,,jpi_itmlist,,,) Read(Unit=ScratchUnit,fmt='(a)',IoStat=Status,Err=20, 1 KeyID=1,Key='F_PRIVACY') mailrec.rec If (Status .ne. 0) GoTo 20 Call Finger_Out_Routine(LF//' Mail: Permission refused by '// 1 'owner.'//CR) GoTo 101 20 Temp = ' ' Call Finger_Out_Routine(LF//' Mail: ') If ( NewMes .eq. 0 ) then Call Finger_Out_Routine('(no new mail)'//CR) GoTo 101 ElseIf ( NewMes .eq. 1 ) then Call Finger_Out_Routine('1 new message.'//CR) ElseIf ( NewMes .gt. 1 ) then Write(Temp,1001)NewMes,' new messages.' ij_nospace = 1 do while (Temp(ij_nospace:ij_nospace) .eq. ' ') ij_nospace = ij_nospace + 1 end do Call Finger_Out_Routine(Temp(ij_nospace:20)//CR) EndIf If ((TestOutput .and. FlagDisSubj) .ne. 0) Goto 99 Read(Unit=ScratchUnit,fmt='(a)',IoStat=Status,Err=99, 1 KeyID=1,Key='NEWMAIL') mailrec.rec foundMail=.false. Do While (status.eq.0) If (len(mailrec.folder).GT.1) then Mail_Time = ' ' Mail_day = Day_oftheWeek (mailrec.date) call sys$asctim(,mail_time,mailrec.date) mail_Time = Make_Pretty(Mail_Time) ptr = 91 csize=mailrec.rec(ptr:ptr+1) ptr=ptr+2 from=mailrec.rec(ptr:ptr+size-1) ptr=ptr+size c Here we check for mail from the fingerer. The simplest case is mail on c the same node. Next is mail from DECnet nodes, stored as node::user. c Then we also have to check for the Bitnet/jnet case, which is difficult c as Bitnet/jnet limits usernames to 8 characters, whereas VMS has 12. We c address this by tacking a '*' onto the fingerer's username if he came c in via Bitnet and the username was 8 characters long. That is done in c FINGERDAE.FOR UpFrom = Str$UpCase(From) FoundSender = 0 If ( (TestOutput .and. FlagIAM) .ne. 0 ) Then F_User = WhoAmI(2:Index(WhoAmI,'~')-1) F_Node = WhoAmI(Index(WhoAmI,'~')+1:l_WhoAmI-1) F_ByAt = F_User(:Btrim(F_User))//'@'// 1 F_Node(:Btrim(F_Node)) c !! Site-specific - If all your DECnet nodes are under common administration c such that Username FRED is the same person at all nodes, you can ignore the c source node when matching user info for mail reporting. If you select this c option, be aware that FRED at any node can see mail sent by FRED at any c other node. This only applies to DECnet mail. Jnet mail always must match c the username and nodename. F_ByColon = F_Node(:Btrim(F_Node))//'::'// 1 F_User(:Btrim(F_User)) c If DECnet access and option selected, allow matching on username alone c Comment out the next 5 lines if you do not want this feature. If (Access .eq. 3) Then F_ByColon = '::'//F_User(:Btrim(F_User)) If (Index(UpFrom,F_User(:Btrim(F_User))) .eq. 1) 1 FoundSender = 1 EndIf If (Index(UpFrom,F_ByAt(:Btrim(F_ByAT))) .gt. 0) Then c Have a match of user@node FoundSender = 1 Else If (Index(UpFrom,F_ByColon(:Btrim(F_ByColon))) 1 .gt. 0) Then c Have a match of node::user FoundSender = 1 Else If (Index(F_User,'*') .gt. 0) Then c Was a >8 username... If ((Index(UpFrom,F_User(:Btrim(F_User)-1)) 1 .gt. 0) c ...and username matched... 2 .and. (Index(UpFrom,'@'//F_Node(:Btrim(F_Node))) 3 .gt. 0)) Then c ...and nodename matched FoundSender = 1 Endif Endif Else if (index(from,you(:btrim(you))).gt.0) then FoundSender = 1 EndIf EndIf if (FoundSender .ne. 0) Then got_subj=.false. subject=' ' fn=0 do while ((.not.(got_subj)).or.(fn.eq.5)) cfn=mailrec.rec(ptr:ptr+1) cfnlen=mailrec.rec(ptr+2:ptr+3) if (fn.eq.2) then subject=mailrec.rec(ptr+4:ptr+4+fnlen-1) got_subj=.true. end if ptr=ptr+4+fnlen end do if (.not.foundMail) then Call Finger_Out_Routine(LF//' Has the following '// 1 'unread message(s) from you:'//CR) foundMail = .true. endif Call Finger_Out_Routine(LF//' '// 1 Mail_Day(:btrim(mail_day))//', '// 2 Mail_Time//' Subj: '// 3 subject(1:jmin0(len(subject),40))//CR) endif endif mailrec.rec = ' ' Read(Unit=ScratchUnit, 1 IoStat=Status, 2 fmt='(a)', 3 End=99) Mailrec.rec If (mailrec.folder(1:7).ne.'NEWMAIL') status = -1 !short cut enddo 99 Continue Call Priv_Close(ScratchUnit) 100 Continue !newmes out of sync c See if there are any new RSCS spool files 101 FindTemplate = 'JAN_COMMON:[RECEIVE]'// 1 UserName(:btrim(username))//'.RSC;*' FindCount = 0 FindContext = 0 102 ii = Lib$Find_File(FindTemplate(:btrim(FindTemplate)), 1 FindResult, FindContext, , , , %loc(2)) If ( ii .ne. RMS$_Normal ) Goto 103 FindCount = FindCount + 1 Goto 102 103 ii = Lib$Find_File_End(FindContext) If ( FindCount .ne. 0 ) Then Call Finger_Out_Routine(LF//' ') Temp = ' ' If ( FindCount .eq. 1 ) Then Call Finger_Out_Routine('1 new RSCS spool file.'//CR) ElseIf ( FindCount .gt. 1 ) Then Write(Temp,1001) FindCount,' new RSCS spool files.' ij_nospace = 1 do while (Temp(ij_nospace:ij_nospace) .eq. ' ') ij_nospace = ij_nospace + 1 end do Call Finger_Out_Routine(Temp(ij_nospace:27)//CR) EndIf 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 IF(.NOT.FLAG_BYPASS)THEN do ibcz=1,l_line if(line(ibcz:ibcz).lt.' ')then iibcz=ichar(line(ibcz:ibcz)) if(iibcz.ne.9.and.iibcz.ne.10 1 .and.iibcz.ne.13)line(ibcz:ibcz)='.' endif enddo ENDIF c end of bypass logic if (l_line .eq. 0) then Call Finger_Out_Routine(LF//CR) else Call Finger_Out_Routine(LF//Line(1:l_line)//CR) EndIf 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(I6,A) 2000 Format(Q,A) End c------------------------------------------------------------------------------ Character*25 Function Get_Location(Terminal,TTType,PID) c This routine returns the location and terminal type, given the c terminal name. It user the data in the shared common section. c ! site-specific c If the terminal begins with LT it is considered a LAT terminal. 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 If the terminal begins with WT or TK it is considered to be an c emulated VT220 or TEK4014 on a VAXStation. c If the terminal begins with TW it is considered to be a DECterm c window under DECWindows. c If the terminal begins with QT it is considered to be a TES terminal c coming from a PC network. c c In the normal situation, the 25 characters returned are c the location and 25 for the type. Obviously these can be c can be shortened for printing (I normally print 15 + 25) Include 'FingerCom.For' c Site-specific c LAT ident stuff c [rph] 01-06-88 - Server names and port names can be as large as c 16 and 12 characters respectively. By default only c the first 8 characters of each are displayed. This c can easily be changed. Include 'fingerdef.inc' Include '($DVIDEF)' Character Server*16, Port*12, Make_Pretty*70 Integer Status Integer Privilege(2) /0,0/ c end LAT ident data Character Terminal*8, TTType*25 Character Network*20, Get_Network*20 Character Node*32, Get_DECnet_Remote*25 Character Get_jnet_Node*8 Integer Btrim, PID Integer Lib$GetDVI External Lib$GetDVI Character Phy_Terminal*8, TT_AccPorNam*64 Integer L_Phy_Terminal, L_TT_AccPorNam, Slash Integer TermType 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 ( Terminal(1:3) .eq. '_VT' ) 1 Terminal=Terminal(2:Btrim(Terminal)) If (index(terminal,':').eq.0) 1 Terminal=Terminal(:Btrim(terminal))//':' Endif c Next, find out what type of terminal VMS thinks it is... If ( Terminal(1:1) .ne. ' ' ) Then Call Lib$GetDVI(DVI$_DevType,,Terminal,TermType,,) Call TypeToTerm(TTType, TermType) EndIf If ( Terminal(1:2) .eq. 'RT' ) Then Get_Location = Get_DECnet_Remote( PID, Node) 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(1:2) .eq. 'WT' ) then Get_Location = 'VT220 window' ElseIf ( Terminal(1:2) .eq. 'TK' ) then Get_Location = 'TEK4014 window' ElseIf ( Terminal(1:2) .eq. 'TW' ) then Get_Location = 'DECterm window' ElseIf ( Terminal(1:2) .eq. 'QT' ) then Get_Location = 'PC Network' ElseIf ( Terminal(1:2) .eq. 'VT' .or. Terminal(1:3) .eq. 'MBA' ) then Get_Location = '' TTType = ' ' ElseIf ((Terminal(1:2) .eq. 'LT') .or. (Terminal(1:2) .eq. 'TN') .or. 1 (Terminal(1:2) .eq. 'NT')) then If ( Terminal(1:2) .eq. 'LT') then Get_Location = 'LAT' EndIf c ** Site-Specific c get LAT info c c getdvi(tt_accpornam) returns a string in the form server/port or for c PSI connections, the originating connection c terminal = '_' // terminal status = Lib$GetDVI(DVI$_TT_AccPorNam,,Terminal,, 1 TT_AccPorNam,L_TT_AccPorNam) terminal = terminal(2:len(terminal)) c This is a hack - when we put the "_" in front of the terminal name above, c we lopped off the trailing ":" because the field is only 8 characters wide. c Changing that in all the places we need to would require changes to the c format of fingershr and so forth. So we'll cheat and stick the colon back c on manually. If (index(terminal,':').eq.0) 1 Terminal=Terminal(:Btrim(terminal))//':' slash = index(TT_AccPorNam,'/') If (Status) then If (slash.gt.0) then Server = TT_AccPorNam(1:slash-1) Port = TT_AccPorNam(slash+1:slash+9) c Don't fool with server and port names - tmk c Server = Make_Pretty(Server) c Port = Make_Pretty(Port) c If the server port name starts with "915-", show things a little c differently (suppress server name, show as "Dialup "+rest_of_port_name. If (Port(1:4) .eq. '915-') Then Get_Location = 'Dialup ' // 1 TT_AccPorNam(slash+1:Btrim(TT_AccPorNam)) Else Get_Location = Server(:Btrim(Server)) // ' ' // 1 Port(:Btrim(Port)) EndIf else !PSI terminal Get_location = TT_AccPorNam(1:btrim(TT_AccPorNam)) if (terminal(1:2) .eq. 'TN') then slash = index(TT_AccPorNam, ' ') Get_location = TT_AccPorNam(slash+1:btrim(TT_AccPorNam)) slash = index(Get_location, ' ') Get_location = Get_location(1:slash-1) endif endif if (TT_AccPorNam(1:4) .eq. 'LAT_') then Get_location = 'PC (Pathworks)' endif if (TT_AccPorNam(1:4) .eq. 'WRQ_') then Get_location = 'PC (Reflection)' endif endif ElseIf ( Terminal(1:2) .eq. 'PX' ) then Get_Location = 'PC Network' Else c search for Terminal in shared common database Do ii = 1,Loc$I_Last If ( Loc$C_Terminal(ii) .eq. Terminal ) then Get_Location = Loc$C_Location(ii) If ( Loc$C_TTType(ii) .ne. 'Unknown' ) Then TTType = Loc$C_TTType(ii) EndIf Return End if End do EndIf Return End c----------------------------------------------------------------------------- Character*25 Function Get_DECnet_Remote(PID,Node) Integer PID Character*(*) Node C c Get the remote DECnet node name and username by getting the JIB C address using $CMKRNL and a small Macro routine. The JIB address is c then used to make-up the name of the JOB logical name table and then C the logcials names SYS$REM_ID and SYS$REM_NODE are translated c from this logical name table. c C Written by: Frank J. Nagy Fermilab Research Division/EED Controls c Include 'FingerDef.inc' Include 'Fingercom.for' Include '($jpidef)' Include '($ssdef)' !FJN Integer i, status, sys$cmkrnl, sys$trnlnm, jib external get_jib_address Integer gja_arglist(3) Character jobtable*20, DECnet_node*8, Username*32 Integer*2 l_jobtable, l_node, l_name Integer TRN_ItemList(4) Integer*2 TRN_ItemList2(8) Equivalence (TRN_ItemList,TRN_ItemList2) Integer TRN$_String /Z00000002/ Integer Privilege(2) /0,0/ gja_arglist(1) = 2 gja_arglist(2) = PID gja_arglist(3) = %LOC( jib) Get_DECnet_Remote = ' ' Node = '?' c Turn on CMKRNL privilege Privilege(1) = Prv$M_Cmkrnl Call Sys$Setprv(%Val(1),Privilege,,) status = sys$cmkrnl( get_jib_address, gja_arglist) c Turn off CMKRNL privilege Call Sys$Setprv(,Privilege,,) If (.Not. status) Then Call Lib$Signal( %Val(status)) Return EndIf If (jib .eq. 0) Return Call Sys$Fao( 'LNM$JOB_!XL', l_jobtable, jobtable, %Val(jib)) 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 c Turn on SYSPRV privilege Privilege(1) = Prv$M_Sysprv Call Sys$Setprv(%Val(1),Privilege,,) status = Sys$TrnLnm(,jobtable(1:l_jobtable), 1 'SYS$REM_NODE', 1, TRN_ItemList) If (status .eq. SS$_NOLOGNAM) Then !FJN c Often fails due to new remote login just starting, wait and retry !FJN Call Lib$Wait( 0.3) !FJN status = Sys$TrnLnm(,jobtable(1:l_jobtable), !FJN 1 'SYS$REM_NODE', 1, TRN_ItemList) !FJN EndIf !FJN c Turn off SYSPRV privilege Call Sys$Setprv(,Privilege,,) If (.Not. status) Then c** Call Lib$Signal( %Val(status)) Get_DECnet_Remote = 'No info available' Return EndIf TRN_ItemList(2) = %Loc(username) TRN_ItemList(3) = %Loc(L_name) c Turn on SYSPRV privilege Privilege(1) = Prv$M_Sysprv Call Sys$Setprv(%Val(1),Privilege,,) status = Sys$TrnLnm(,jobtable(1:l_jobtable), 1 'SYS$REM_ID', 1, TRN_ItemList) c Turn off SYSPRV privilege Call Sys$Setprv(,Privilege,,) If (.Not. status) Then Call Lib$Signal( %Val(status)) Return EndIf Get_DECnet_Remote = DECnet_node(1:L_node)// 1 username(1:l_name) Node = DECnet_node(1:L_node-2) return end c----------------------------------------------------------------------------- Character*5 Function Get_Idle(Terminal) Include 'Fingercom.for' Integer I_hr, I_min, Status, Offset Character*(*) Terminal Integer*4 I_Idle, Term_PID Integer*2 RTT_Link Integer*4 Term_info Integer Btrim Character*16 lterminal Common /Term_Info_Struct/ I_Idle, Term_PID, RTT_Link Get_Idle = ' ' c Call TERM_INFO to get the idle time for terminals. Make sure that c I_Idle is zero first or it will use the previous value. TERM_INFO c wants the ':' in the terminal name, so make sure we have at least c one. I_Idle = 0 lterminal = terminal(:btrim(terminal))//':' Offset = Index(lTerminal, ':') Status = TERM_INFO(lTerminal(:Offset), I_Idle) 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*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*20 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 ( Rl_Imagname .eq. 0 ) 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*31 Function Get_PersonalName(Username) Include 'FingerCom.For' Character*12 UserName ! User's login name Character*31 Owner, Fix_Name*31 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*31, Str$UpCase*31 Character Fix_Name*31, Make_Pretty*31 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)//' - '// c ! site-specific: Choose one of the following two lines 1 Fix_Name(Usr$C_PersonalName(ii)) c 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 'Mon', 2 'Tue', 3 'Wed', 4 'Thu', 5 'Fri', 6 'Sat', 7 'Sun'/ 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*31 Function Fix_Name(Name) Character Name*31, First_Name*31, Last_Name*31 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 = 31 - 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 c ! site-specific: Uncomment next line if your usernames are stored as c lastname, firstname. c 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.INC' 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,,) priv_close=1 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 (PID .eq. 0) then Index = 0 Return EndIf 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------------------------------------------------------------------ Character*20 Function Get_LastName(Username) Include 'GETJPIDEF' Include 'FingerFlg' Include 'Fingerdef.inc' Logical IsPrint Character ToUpper Character*31 Get_PersonalName, PersonalName, LastName Integer Length, Pointer, Btrim, Index, End PersonalName = Get_PersonalName(Username) Length = Btrim(PersonalName) if (Length .eq. 1) Then Get_LastName = ' ' return endif 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 Logical Function Wild_Parse( Name, NonWild) !FJN Character*(*) Name !FJN Integer NonWild !FJN Wild_Parse = .false. !FJN NonWild = 0 !FJN c Scan for wild card characters "*" and "%", count non-wild characters !FJN Do i = 1,LEN(Name) !FJN If ( Name(i:i) .eq. '*' ) Then !FJN Wild_Parse = .true. !FJN Else If ( Name(i:i) .eq. '%' ) Then !FJN Wild_Parse = .true. !FJN Else If ( Name(i:i) .ne. ' ' ) Then !FJN NonWild = NonWild + 1 !FJN End If !FJN Enddo !FJN Return !FJN End !FJN c------------------------------------------------------------------ SUBROUTINE XABSET ( xabpro ) C INCLUDE 'XABPRODEF.INC' 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.INC' 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 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