Program Cspy C********************************************************************* C* C* PROGRAM: Cspy (Cluster SPY) C* C* C* PURPOSE: VMS currently will not let you do a Spy ($ SHOW PROC/CONT/ID=) C* over a different cluster node. CSpy (Cluster-wide Spy) was written C* to allow just that. C* C* C* OPERATION: CSPY remote_pid C* C* C* ENVIRONMENT: VAX VMS V5.2 C* VAX Fortran 5.3 C* C* RESTRICTIONS: Must have standard SPY privileges (GROUP and/or WORLD). C* Define CSPY as a foreign symbol C* (i.e., CSPY == "$directory:CSPY") C* C* C* Information America C* Systems Department C* J. Wren Hunt C* February 3, 1990 C* C* MODIFICATION HISTORY: C* C* C********************************************************************** implicit none include '($jpidef)' include '($pscandef)' include 'SMG_Stuff.inc' C++++++++++++++++++++ C C External Routines C C++++++++++++++++++++ integer*4 sys$process_scan,sys$getjpi,sys$getjpiw,lib$get_foreign, 1 ots$cvt_tz_l,ots$cvt_l_tu,sys$idtoasc C+++++++++++++++++++++ C C Local/global variables C C++++++++++++++++++++++ logical show_screen,SDA_screen integer*2 iosb(4),nodename_len,prcnam_len,imagname_len,pid_len, 1 terminator,namlen,upper_e,lower_e,upper_v,lower_v,ptr,space integer*2 resid(2),grpid(2),memlen,grplen,holder(2) integer*4 ots$cvt_l_tz,group,res integer*4 context,jpiflags,numeric_pid,decimal,i,str$upcase, 1 jpi_pid,jpi_bufio,jpi_dirio,jpi_cputim,jpi_pageflts, 2 jpi_pri,jpi_prib,jpi_uic,jpi_uaf_flags,jpi_virtpeak, 3 jpi_wssize,jpi_state,seconds,minutes,hours,days, 4 jpi_astact,jpi_astcnt,jpi_asten,jpi_astlm,jpi_efcs, 5 jpi_efcu,jpi_efwm,jpi_enqcnt,jpi_enqlm,jpi_filcnt, 6 jpi_fillm,jpi_gpgcnt,jpi_jobprccnt,jpi_logintim, 7 jpi_tmbu,jpi_tqcnt,jpi_tqlm,jpi_sts,jpi_proc_index, 8 jpi_master_pid,jpi_biocnt,jpi_biolm,jpi_diocnt, 9 jpi_diolm,jpi_aptcnt,jpi_bytcnt,jpi_bytlm integer*4 milliseconds character*2 tpri,tprib,tseconds,tminutes,thours,tdays,tmilliseconds character*4 tasten,tastact,tastcnt,tbiocnt,tbiolm,tdiocnt,tdiolm, 1 tbytcnt,tbytlm,tfilcnt,t_tqcnt character*8 tstate,twssize,tvirtpeak,tbufio,tdirio,tsts,t_efcs, 1 tcputim,tpageflts,tproc_index,t_efcu,t_efwm,taptcnt, 2 tjobprccnt,tmaster_pid,tmbu character*16 prcnam,nodename,pid,cpu_time character*30 line character*80 imagname,text,nambuf character*255 mem,grp equivalence (group,grpid), (res,resid) structure /item_list/ integer*2 buflen integer*2 item_code integer*4 bufadr integer*4 retlen end structure structure /pscan_list/ integer*2 buflen integer*2 item_code integer*4 bufadr integer*4 itmflags end structure record /item_list/ itmlst(50) record /pscan_list/ pscanlst(10) integer*4 sch$c_cef,sch$c_com,sch$c_como,sch$c_cur,sch$c_colpg, 1 sch$c_fpg,sch$c_hib,sch$c_hibo,sch$c_lef,sch$c_lefo, 2 sch$c_mwait,sch$c_pfw,sch$c_susp,sch$c_suspo PARAMETER (SCH$C_COLPG = 1) PARAMETER (SCH$C_MWAIT = 2) PARAMETER (SCH$C_CEF = 3) PARAMETER (SCH$C_PFW = 4) PARAMETER (SCH$C_LEF = 5) PARAMETER (SCH$C_LEFO = 6) PARAMETER (SCH$C_HIB = 7) PARAMETER (SCH$C_HIBO = 8) PARAMETER (SCH$C_SUSP = 9) PARAMETER (SCH$C_SUSPO = 10) PARAMETER (SCH$C_FPG = 11) PARAMETER (SCH$C_COM = 12) PARAMETER (SCH$C_COMO = 13) PARAMETER (SCH$C_CUR = 14) Upper_E = 69 Lower_E = 101 Upper_V = 86 Lower_V = 118 Space = 32 C*********************************************************** C C M A I N L I N E C O D E S T A R T S H E R E C C*********************************************************** C Setup the SMG stuff so we can have a right-nice lookin' display! Call SMG_Setup C See which remote PID the user specified on the command line sts$value = lib$get_foreign(pid,,pid_len) if (.not. sts$value) call lib$signal(%val(sts$value)) C Convert hexadecimal text to unsigned integer. Size is 4 bytes sts$value = ots$cvt_tz_l(pid(1:pid_len),numeric_pid,%val(4)) if (.not. sts$value) call lib$signal(%val(sts$value)) C Initialize item list for $PROCESS_SCAN pscanlst(1).buflen = 0 ! Specify cluster id <> 0 gives all nodes pscanlst(1).item_code = pscan$_node_csid pscanlst(1).bufadr = 0 pscanlst(1).itmflags = pscan$m_neq pscanlst(2).buflen = 0 pscanlst(2).item_code = PSCAN$_master_pid pscanlst(2).bufadr = numeric_pid pscanlst(2).itmflags = pscan$m_eql pscanlst(3).buflen = 0 pscanlst(3).item_code = 0 C Clear out all the $GETJPI control flags 'cause we're gonna specify C some of 'em in a minute. itmlst(1).buflen = 4 itmlst(1).item_code = iand('ffff'x, jpi$_getjpi_control_flags) itmlst(1).bufadr = %loc(jpiflags) itmlst(1).retlen = 0 itmlst(2).buflen = len(nodename) itmlst(2).item_code = jpi$_nodename itmlst(2).bufadr = %loc(nodename) itmlst(2).retlen = %loc(nodename_len) itmlst(3).buflen = len(imagname) itmlst(3).item_code = jpi$_imagname itmlst(3).bufadr = %loc(imagname) itmlst(3).retlen = %loc(imagname_len) itmlst(4).buflen = len(prcnam) itmlst(4).item_code = jpi$_prcnam itmlst(4).bufadr = %loc(prcnam) itmlst(4).retlen = %loc(prcnam_len) itmlst(5).buflen = 4 itmlst(5).item_code = jpi$_pid itmlst(5).bufadr = %loc(jpi_pid) itmlst(5).retlen = 0 itmlst(6).buflen = 4 itmlst(6).item_code = jpi$_bufio itmlst(6).bufadr = %loc(jpi_bufio) itmlst(6).retlen = 0 itmlst(7).buflen = 4 itmlst(7).item_code = jpi$_cputim itmlst(7).bufadr = %loc(jpi_cputim) itmlst(7).retlen = 0 itmlst(8).buflen = 4 itmlst(8).item_code = jpi$_dirio itmlst(8).bufadr = %loc(jpi_dirio) itmlst(8).retlen = 0 itmlst(9).buflen = 4 itmlst(9).item_code = jpi$_pageflts itmlst(9).bufadr = %loc(jpi_pageflts) itmlst(9).retlen = 0 itmlst(10).buflen = 4 itmlst(10).item_code = jpi$_pri itmlst(10).bufadr = %loc(jpi_pri) itmlst(10).retlen = 0 itmlst(11).buflen = 4 itmlst(11).item_code = jpi$_prib itmlst(11).bufadr = %loc(jpi_prib) itmlst(11).retlen = 0 itmlst(12).buflen = 4 itmlst(12).item_code = jpi$_uic itmlst(12).bufadr = %loc(jpi_uic) itmlst(12).retlen = 0 itmlst(13).buflen = 4 itmlst(13).item_code = jpi$_uaf_flags itmlst(13).bufadr = %loc(jpi_uaf_flags) itmlst(13).retlen = 0 itmlst(14).buflen = 4 itmlst(14).item_code = jpi$_virtpeak itmlst(14).bufadr = %loc(jpi_virtpeak) itmlst(14).retlen = 0 itmlst(15).buflen = 4 itmlst(15).item_code = jpi$_wssize itmlst(15).bufadr = %loc(jpi_wssize) itmlst(15).retlen = 0 itmlst(16).buflen = 4 itmlst(16).item_code = jpi$_state itmlst(16).bufadr = %loc(jpi_state) itmlst(16).retlen = 0 itmlst(17).buflen = 4 itmlst(17).item_code = jpi$_astact ! access modes having active ASTs itmlst(17).bufadr = %loc(jpi_astact) itmlst(17).retlen = 0 itmlst(18).buflen = 4 itmlst(18).item_code = jpi$_astcnt ! count of remaining AST quota itmlst(18).bufadr = %loc(jpi_astcnt) itmlst(18).retlen = 0 itmlst(19).buflen = 4 itmlst(19).item_code = jpi$_asten ! access modes having ASTs enabled itmlst(19).bufadr = %loc(jpi_asten) itmlst(19).retlen = 0 itmlst(20).buflen = 4 itmlst(20).item_code = jpi$_astlm itmlst(20).bufadr = %loc(jpi_astlm) itmlst(20).retlen = 0 itmlst(21).buflen = 4 itmlst(21).item_code = jpi$_efcs ! local event flags 0 - 31 itmlst(21).bufadr = %loc(jpi_efcs) itmlst(21).retlen = 0 itmlst(22).buflen = 4 itmlst(22).item_code = jpi$_efcu ! local event flags 32 - 63 itmlst(22).bufadr = %loc(jpi_efcu) itmlst(22).retlen = 0 itmlst(23).buflen = 4 itmlst(23).item_code = jpi$_efwm ! process's event flag wait mask itmlst(23).bufadr = %loc(jpi_efwm) itmlst(23).retlen = 0 itmlst(24).buflen = 4 itmlst(24).item_code = jpi$_enqcnt ! remaining lock request quota itmlst(24).bufadr = %loc(jpi_enqcnt) itmlst(24).retlen = 0 itmlst(25).buflen = 4 itmlst(25).item_code = jpi$_enqlm ! process's lock request quota itmlst(25).bufadr = %loc(jpi_enqlm) itmlst(25).retlen = 0 itmlst(26).buflen = 4 itmlst(26).item_code = jpi$_filcnt ! process's remaining open file quota itmlst(26).bufadr = %loc(jpi_filcnt) itmlst(26).retlen = 0 itmlst(27).buflen = 4 itmlst(27).item_code = jpi$_fillm ! process's open file limit quota itmlst(27).bufadr = %loc(jpi_fillm) itmlst(27).retlen = 0 itmlst(28).buflen = 4 itmlst(28).item_code = jpi$_gpgcnt ! global page count in working set itmlst(28).bufadr = %loc(jpi_gpgcnt) itmlst(28).retlen = 0 itmlst(29).buflen = 4 itmlst(29).item_code = jpi$_jobprccnt ! total # subprocesses owned itmlst(29).bufadr = %loc(jpi_jobprccnt) itmlst(29).retlen = 0 itmlst(30).buflen = 4 itmlst(30).item_code = jpi$_logintim ! time which process was created itmlst(30).bufadr = %loc(jpi_logintim) itmlst(30).retlen = 0 itmlst(31).buflen = 4 itmlst(31).item_code = jpi$_tmbu ! termination mailbox unit # itmlst(31).bufadr = %loc(jpi_tmbu) itmlst(31).retlen = 0 itmlst(32).buflen = 4 itmlst(32).item_code = jpi$_tqcnt ! remaining timer queue entry quota itmlst(32).bufadr = %loc(jpi_tqcnt) itmlst(32).retlen = 0 itmlst(33).buflen = 4 itmlst(33).item_code = jpi$_tqlm ! limit on timer queue entries itmlst(33).bufadr = %loc(jpi_tqlm) itmlst(33).retlen = 0 itmlst(34).buflen = 4 itmlst(34).item_code = jpi$_sts ! process's status flags itmlst(34).bufadr = %loc(jpi_sts) itmlst(34).retlen = 0 itmlst(35).buflen = 4 itmlst(35).item_code = jpi$_proc_index itmlst(35).bufadr = %loc(jpi_proc_index) itmlst(35).retlen = 0 itmlst(36).buflen = 4 itmlst(36).item_code = jpi$_master_pid itmlst(36).bufadr = %loc(jpi_master_pid) itmlst(36).retlen = 0 itmlst(37).buflen = 4 itmlst(37).item_code = jpi$_biocnt itmlst(37).bufadr = %loc(jpi_biocnt) itmlst(37).retlen = 0 itmlst(38).buflen = 4 itmlst(38).item_code = jpi$_biolm itmlst(38).bufadr = %loc(jpi_biolm) itmlst(38).retlen = 0 itmlst(39).buflen = 4 itmlst(39).item_code = jpi$_diocnt itmlst(39).bufadr = %loc(jpi_diocnt) itmlst(39).retlen = 0 itmlst(40).buflen = 4 itmlst(40).item_code = jpi$_diolm itmlst(40).bufadr = %loc(jpi_diolm) itmlst(40).retlen = 0 itmlst(41).buflen = 4 itmlst(41).item_code = jpi$_aptcnt itmlst(41).bufadr = %loc(jpi_aptcnt) itmlst(41).retlen = 0 itmlst(42).buflen = 0 itmlst(42).item_code = 0 SDA_screen = .False. show_screen = .True. jpiflags = jpi$m_no_target_inswap .or. jpi$m_ignore_target_status 100 sts$value = sys$process_scan(context,pscanlst) if (.not. sts$value) call lib$signal(%val(sts$value)) C Startup priming read sts$value = sys$getjpiw(,context,,itmlst,iosb,,) if (.not. sts$value) call lib$signal(%val(sts$value)) if (.not. iosb(1)) return ! no more processes (nopriv !?!?) sts$value = iosb(1) do while (sts$value) C If it matches then spill it out. if (numeric_pid .eq. jpi_pid) then C Convert UIC to identifier name sts$value = sys$idtoasc(%val(jpi_uic),namlen,nambuf,resid,,) if (.not. sts$value) call lib$signal(%val(sts$value)) C If the high order bit of the RESID argument is clear, RESID contains C a UIC in standard VMS syntax, i.e. the group is in the high-order C word and the member is in the low-order word. If the high-order C bit is set, then RESID contains an Identifier. c if (bjtest (res, 31)) then C Set up to translate the GROUP. grpid(2) = resid(2) grpid(1) = '177777'o sts$value = sys$idtoasc (%val(group), grplen, grp,,,) if (.not. sts$value) call lib$signal(%val(sts$value)) c end if if (show_screen) then C Convert all numeric values into text so that SMG can C display them. sts$value = ots$cvt_l_tu(jpi_wssize,twssize) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(jpi_pri,tpri) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(jpi_prib,tprib) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(jpi_virtpeak,tvirtpeak) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(jpi_pageflts,tpageflts) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(jpi_bufio,tbufio) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(jpi_dirio,tdirio) if (.not. sts$value) call lib$signal(%val(sts$value)) if (jpi_state .eq. sch$c_cef) tstate = 'CEF' if (jpi_state .eq. sch$c_com) tstate = 'COM' if (jpi_state .eq. sch$c_cur) tstate = 'CUR' if (jpi_state .eq. sch$c_colpg) tstate = 'COLPG' if (jpi_state .eq. sch$c_fpg) tstate = 'FPG' if (jpi_state .eq. sch$c_hib) tstate = 'HIB' if (jpi_state .eq. sch$c_lef) tstate = 'LEF' if (jpi_state .eq. sch$c_mwait) tstate = 'MWAIT' if (jpi_state .eq. sch$c_pfw) tstate = 'PFW' if (jpi_state .eq. sch$c_susp) tstate = 'SUSP' text = 'Process ' // prcnam(1:prcnam_len) sts$value = smg$put_chars(contents_id,text,1,31) text = 'Node: ' // nodename(1:nodename_len) sts$value = smg$put_chars(contents_id,text,2,31) text = 'State ' // tstate // 1 ' Working Set ' // twssize sts$value = smg$put_chars(contents_id,text,5,2) text = 'Cur/Base Priority ' // tpri // '/' // tprib // 1 ' Virtual Pages ' // tvirtpeak sts$value = smg$put_chars(contents_id,text,7,2) milliseconds = mod(jpi_cputim,100) seconds = (jpi_cputim) / 100 if (seconds .ge. 86400) then ! # seconds per day days = seconds / 86400 seconds = mod(seconds,86400) end if if (seconds .ge. 3600) then ! # seconds per hour hours = seconds / 3600 seconds = mod(seconds,3600) end if if (seconds .ge. 60) then ! # seconds per minute minutes = seconds / 60 seconds = mod(seconds,60) end if sts$value = ots$cvt_l_tu(milliseconds,tmilliseconds) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(seconds,tseconds) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(minutes,tminutes) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(hours,thours) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(days,tdays) if (.not. sts$value) call lib$signal(%val(sts$value)) cpu_time = tdays // ':' // thours // ':' // tminutes // ':' // 1 tseconds // '.' // tmilliseconds C Filter out intervening blanks in the cpu time Call Remove_blanks(cpu_time) text = 'CPU Time: ' // cpu_time sts$value = smg$put_chars(contents_id,text,9,2) text = 'Direct I/O ' // tdirio // ' Buffered I/O ' // tbufio sts$value = smg$put_chars(contents_id,text,11,2) text = 'PID ' // pid // ' Page Faults ' // tpageflts sts$value = smg$put_chars(contents_id,text,13,2) text = 'UIC [' // grp(1:grplen) // ',' // 1 nambuf(1:namlen) // ']' sts$value = smg$put_chars(contents_id,text,15,2) if (imagname_len .gt. 0) then sts$value = smg$put_chars(contents_id,imagname(1:imagname_len), 1 19,2) end if end if ! screen flag c ******************************************************* if (sda_screen) then c Start display batching sts$value = smg$begin_display_update(contents_id) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = ots$cvt_l_tu(jpi_proc_index,tproc_index) ! convert to text format text = 'Process index:' // tproc_index sts$value = smg$put_chars(contents_id,text,1,2) text = 'Name: ' // prcnam(1:prcnam_len) sts$value = smg$put_chars(contents_id,text,1,26) text = 'Extended PID: ' // pid sts$value = smg$put_chars(contents_id,text,1,50) C $PCBDEF not included in FORSYSDEF.TLB Ptr = 4 line = ' ' if (bjtest(jpi_sts,17)) call build_status_line(ptr,line,'ASTPEN') if (bjtest(jpi_sts,14)) call build_status_line(ptr,line,'BATCH ') if (bjtest(jpi_sts,1 )) call build_status_line(ptr,line,'DELPEN') if (bjtest(jpi_sts,24)) call build_status_line(ptr,line,'DISAWS') if (bjtest(jpi_sts,2 )) call build_status_line(ptr,line,'FORCPEN') if (bjtest(jpi_sts,19)) call build_status_line(ptr,line,'HIBER ') if (bjtest(jpi_sts,3 )) call build_status_line(ptr,line,'INQUAN') if (bjtest(jpi_sts,25)) call build_status_line(ptr,line,'INTER ') if (bjtest(jpi_sts,20)) call build_status_line(ptr,line,'LOGIN ') if (bjtest(jpi_sts,21)) call build_status_line(ptr,line,'NETWRK') if (bjtest(jpi_sts,15)) call build_status_line(ptr,line,'NOACNT') if (bjtest(jpi_sts,23)) call build_status_line(ptr,line,'NODELET') if (bjtest(jpi_sts,18)) call build_status_line(ptr,line,'PHDRES') if (bjtest(jpi_sts,4 )) call build_status_line(ptr,line,'PSWAPM') if (bjtest(jpi_sts,22)) call build_status_line(ptr,line,'PWRAST') if (bjtest(jpi_sts,26)) call build_status_line(ptr,line,'RECOVER') if (bjtest(jpi_sts,0 )) call build_status_line(ptr,line,'RES ') if (bjtest(jpi_sts,5 )) call build_status_line(ptr,line,'RESPEN') if (bjtest(jpi_sts,6 )) call build_status_line(ptr,line,'SSFEXC') if (bjtest(jpi_sts,7 )) call build_status_line(ptr,line,'SSFEXCE') if (bjtest(jpi_sts,8 )) call build_status_line(ptr,line,'SSFEXCS') if (bjtest(jpi_sts,9 )) call build_status_line(ptr,line,'SSFEXCSU') if (bjtest(jpi_sts,10)) call build_status_line(ptr,line,'SSRWAIT') if (bjtest(jpi_sts,11)) call build_status_line(ptr,line,'SUSPEN') if (bjtest(jpi_sts,12)) call build_status_line(ptr,line,'WAKEPEN') if (bjtest(jpi_sts,13)) call build_status_line(ptr,line,'WALL ') ptr = ptr - 1 line(ptr:ptr) = ' ' ! remove last ',' sts$value = ots$cvt_l_tu(jpi_sts,tsts) ! convert to text format text = 'Process status: ' // tsts // line sts$value = smg$put_chars(contents_id,text,3,2) text = 'State: ' // tstate sts$value = smg$put_chars(contents_id,text,5,2) text = 'Current Priority: ' // tpri sts$value = smg$put_chars(contents_id,text,6,2) text = 'Base priority: ' // tprib sts$value = smg$put_chars(contents_id,text,7,2) text = 'UIC: [' // grp(1:grplen) // ',' // 1 nambuf(1:namlen) // ']' sts$value = smg$put_chars(contents_id,text,8,2) C Event flag clusters are returned as a longword bit vector. Convert these C to hex for display purposes. sts$value = ots$cvt_l_tz(jpi_efwm,t_efwm,%val(8),%val(4)) if (.not. sts$value) call lib$signal(%val(sts$value)) text = 'Event flag wait mask' // ' ' // t_efwm sts$value = smg$put_chars(contents_id,text,9,2) sts$value = ots$cvt_l_tz(jpi_efcs,t_efcs,%val(8),%val(4)) if (.not. sts$value) call lib$signal(%val(sts$value)) text = 'Local EF cluster 0:' // ' ' // t_efcs sts$value = smg$put_chars(contents_id,text,10,2) sts$value = ots$cvt_l_tz(jpi_efcu,t_efcu,%val(8),%val(4)) if (.not. sts$value) call lib$signal(%val(sts$value)) text = 'Local EF cluster 1:' // ' ' // t_efcu sts$value = smg$put_chars(contents_id,text,11,2) sts$value = ots$cvt_l_tu(jpi_jobprccnt,tjobprccnt) ! convert to text format text = 'Subprocess count: ' // tjobprccnt sts$value = smg$put_chars(contents_id,text,5,43) sts$value = ots$cvt_l_tz(jpi_master_pid,tmaster_pid,%val(8),%val(4)) text = 'Creator extended PID: ' // tmaster_pid sts$value = smg$put_chars(contents_id,text,6,43) sts$value = ots$cvt_l_tu(jpi_tmbu,tmbu) ! convert to text format text = 'Termination mailbox: ' // tmbu sts$value = smg$put_chars(contents_id,text,7,43) tasten = ' ' ptr = 1 if (bjtest(jpi_asten,0)) then tasten(ptr:ptr) = 'K' ptr = ptr + 1 end if if (bjtest(jpi_asten,1)) then tasten(ptr:ptr) = 'E' ptr = ptr + 1 end if if (bjtest(jpi_asten,2)) then tasten(ptr:ptr) = 'S' ptr = ptr + 1 end if if (bjtest(jpi_asten,3)) then tasten(ptr:ptr) = 'U' end if if (tasten .eq. ' ') tasten = 'NONE' text = 'ASTs enabled: ' // tasten sts$value = smg$put_chars(contents_id,text,8,43) tastact = ' ' ptr = 1 if (bjtest(jpi_ASTACT,0)) then tASTACT(ptr:ptr) = 'K' ptr = ptr + 1 end if if (bjtest(jpi_ASTACT,1)) then tASTACT(ptr:ptr) = 'E' ptr = ptr + 1 end if if (bjtest(jpi_ASTACT,2)) then tASTACT(ptr:ptr) = 'S' ptr = ptr + 1 end if if (bjtest(jpi_ASTACT,3)) then tASTACT(ptr:ptr) = 'U' end if if (tastact .eq. ' ') tastact = 'NONE' text = 'ASTs active: ' // tastact sts$value = smg$put_chars(contents_id,text,9,43) sts$value = ots$cvt_l_tu(jpi_astcnt,tastcnt) ! convert to text format text = 'ASTs remaining: ' // tastcnt sts$value = smg$put_chars(contents_id,text,10,43) sts$value = ots$cvt_l_tu(jpi_biocnt,tbiocnt) ! convert to text format sts$value = ots$cvt_l_tu(jpi_biolm,tbiolm) ! convert to text format text = 'Buffered I/O count/limit: ' // tbiocnt // '/' // tbiolm sts$value = smg$put_chars(contents_id,text,11,43) sts$value = ots$cvt_l_tu(jpi_diocnt,tdiocnt) ! convert to text format sts$value = ots$cvt_l_tu(jpi_diolm,tdiolm) ! convert to text format text = 'Direct I/O count/limit: ' // tdiocnt // '/' // tdiolm sts$value = smg$put_chars(contents_id,text,12,43) sts$value = ots$cvt_l_tu(jpi_bytcnt,tbytcnt) ! convert to text format sts$value = ots$cvt_l_tu(jpi_bytlm,tbytlm) ! convert to text format text = 'BUFIO byte count/limit: ' // tbytcnt // '/' // tbytlm sts$value = smg$put_chars(contents_id,text,13,43) sts$value = ots$cvt_l_tu(jpi_filcnt,tfilcnt) ! convert to text format text = '# open files allowed left: ' // tfilcnt sts$value = smg$put_chars(contents_id,text,14,43) sts$value = ots$cvt_l_tu(jpi_tqcnt,t_tqcnt) ! convert to text format text = 'Timer entries allowed left: ' // t_tqcnt sts$value = smg$put_chars(contents_id,text,15,43) sts$value = ots$cvt_l_tu(jpi_aptcnt,taptcnt) ! convert to text format text = 'Active page table count: ' // taptcnt sts$value = smg$put_chars(contents_id,text,16,43) sts$value = smg$end_display_update(contents_id) if (.not. sts$value) call lib$signal(%val(sts$value)) end if ! sda flag end if ! pid match sts$value = sys$getjpiw(,context,,itmlst,iosb,,) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = iosb(1) end do C Loop forever spying on the process until the user presses 'E' to exit. C (If 'V' key is pressed, then show SDA equivalent display) sts$value = smg$read_keystroke(keyboard_id,terminator,,1) if (terminator .eq. upper_e .or. terminator .eq. lower_e) then sts$value = smg$delete_pasteboard(pasteboard,1) if (.not. sts$value) call lib$signal(%val(sts$value)) call exit end if if (terminator .eq. upper_v .or. terminator .eq. lower_v) then sts$value = smg$erase_display(contents_id) show_screen = .false. sda_screen = .true. terminator = 0 end if if (terminator .eq. space) then sts$value = smg$erase_display(contents_id) show_screen = .true. sda_screen = .false. terminator = 0 end if c Start the whole thing over goto 100 end ! of Mainline program Subroutine OUT_OF_BAND_ROUTINE(smg_info,r0,r1,pc,psl) C***************************************************************************** C C This routine handles "out-of-band" AST's that are generated whenever a C user types CTRL/R or CTRL/W on the screen. These character sequences will C repaint the screen thus getting rid of any broadcast messages etc., C C C Information America C Wren Hunt C February 1990 C C These are the arguments that are passed to us from the AST: C C +---------------------------+ +---------------------+ C ! address of data structure !-------> ! SMG$L_PASTEBOARD_ID ! C +---------------------------+ +---------------------+ C ! R0 ! ! SMG$L_ARG ! C +---------------------------+ +---------------------+ C ! R1 ! ! blanks ! ! C +---------------------------+ +---------------------+ C ! PC ! 31 8 7 ^ 0 C +---------------------------+ ! C ! PSL ! SMG$B_CHARACTER C +---------------------------+ C***************************************************************************** implicit none include 'smg_stuff.inc' record /smg$r_out_of_band_table/ smg_info integer*4 address,r0,r1,pc,psl character*1 user_character sts$value = smg$repaint_screen(pasteboard) if (.not. sts$value) call lib$signal(%val(sts$value)) end Subroutine Remove_Blanks(text) C***************************************************************************** C C This routine copies an input string to another string, removing blanks C in the process. The 'deblanked' string is then returned. C C C Information America C Wren Hunt C June 1991 C C***************************************************************************** implicit none character*(*) text character*30 output_text integer*2 i,j J = 1 Do i = 1,len(text) if (text(i:i) .ne. ' ') then output_text(j:j) = text(i:i) j = j + 1 end if End Do text = output_text(1:j) end ! REMOVE_BLANKS Subroutine Smg_setup C********************************************************************** C C This routine handles the prelimanary SMG setup required to get C everything going. C C J. Wren Hunt C March 1990 C C********************************************************************** implicit none include 'SMG_Stuff.inc' ! contains COMMONs to pass data from ! mainline to subroutines and vice-versa. external out_of_band_routine ! implements CTRL/R & CTRL/W ! "out-of-bands" refresh characters C+++++++++++++++++++++ C C Local/global variables C C++++++++++++++++++++++ integer*4 num_rows,num_columns,control_char_mask sts$value = smg$create_pasteboard(pasteboard,'sys$output', 1 num_rows,num_columns) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = smg$create_virtual_display(22,78,contents_id) if (.not. sts$value) call lib$signal(%val(sts$value)) C Display for the SDA screen sts$value = smg$create_virtual_display(22,78,SDA_id) if (.not. sts$value) call lib$signal(%val(sts$value)) C Put labels around each display sts$value = smg$label_border(contents_id,'Cluster Spy Utility', 1 smg$k_top,,smg$m_bold) if (.not. sts$value) call lib$signal(%val(sts$value)) C Create a virtual keyboard. sts$value = smg$create_virtual_keyboard(keyboard_id) if (.not. sts$value) call lib$signal(%val(sts$value)) C Paste the virtual display(s) to the pasteboard. sts$value = smg$paste_virtual_display(contents_id,pasteboard,2,2) if (.not. sts$value) call lib$signal(%val(sts$value)) C The following is a bit mask which read from right to left C starts with bit 0, followed by bit 1 (A) etc., As you C can see, bits 18 & 23 are set meaning that an out-of-bands C AST is set for CTRL/R & CTRL/W ("Refresh" and "Wipe") C The binary value of 00000000100001000000000000000000 has been C converted to a Hexadecimal value below. (You may also use C exponential notation to arrive at this value. e.g., 2**18) control_char_mask = '00840000'X sts$value = smg$set_out_of_band_asts(pasteboard,control_char_mask, 1 out_of_band_routine) if (.not. sts$value) call lib$signal(%val(sts$value)) end ! SMG_SETUP Subroutine Build_status_line(ptr,line,flag) C***************************************************************************** C C This routine builds the process 'status line' (e.g., RES,INTER,PHDRES) C It determines where in the line to place each process attribute and delimits C each one with commas. C C***************************************************************************** implicit none integer*2 ptr,i character*80 line character*7 flag do i = 1,7 ! maximum length of process 'flag' attribute. if (flag(i:i) .ne. ' ') then line(ptr:ptr) = flag(i:i) ptr = ptr + 1 end if end do C insert comma to delimit line(ptr:ptr) = ',' ptr = ptr + 1 end C SMG_STUFF.INC include '($ssdef)' include '($smgdef)' integer*4 smg$label_border,smg$create_virtual_display, 1 smg$create_virtual_keyboard,smg$paste_virtual_display, 2 smg$create_pasteboard,smg$put_chars,smg$put_with_scroll, 3 smg$scroll_display_area,smg$read_keystroke, 5 smg$erase_display, 6 smg$set_broadcast_trapping,smg$set_out_of_band_asts, 9 smg$repaint_screen,smg$delete_pasteboard, 1 smg$begin_display_update,smg$end_display_update integer*4 sts$value,pasteboard,contents_id,directory_id integer*4 statistics_id,menu_id,keyboard_id,SDA_id common /stuff/ pasteboard,contents_id,directory_id,statistics_id, 1 menu_id,keyboard_id,SDA_id C SMG_STUFF.INC C Used by CSPY.FOR include '($ssdef)' include '($smgdef)' integer*4 smg$label_border,smg$create_virtual_display, 1 smg$create_virtual_keyboard,smg$paste_virtual_display, 2 smg$create_pasteboard,smg$put_chars,smg$put_with_scroll, 3 smg$scroll_display_area,smg$read_keystroke, 5 smg$erase_display, 6 smg$set_broadcast_trapping,smg$set_out_of_band_asts, 9 smg$repaint_screen,smg$delete_pasteboard, 1 smg$begin_display_update,smg$end_display_update integer*4 sts$value,pasteboard,contents_id,directory_id integer*4 statistics_id,menu_id,keyboard_id,SDA_id common /stuff/ pasteboard,contents_id,directory_id,statistics_id, 1 menu_id,keyboard_id,SDA_id