$! BUILD_QCLEAN.COM $! $! $ SET NOON $! $ FORTRAN/EXTEND/CHECK=ALL QCLEAN $! $ SET COMMAND/OBJECT QCLEAN_TABLE $! $ LINK/MAP/FULL/NOTRACE QCLEAN,QCLEAN_TABLE $! $ INQUIRE ANS "Would you like to update the system help library" $! $ IF ANS .EQS. "Y" THEN LIBRARY/HELP/LOG SYS$HELP:HELPLIB QCLEAN.HLP $! $ WRITE SYS$OUTPUT "That's all folks!!!" $! $ EXIT PROGRAM QCLEAN_DRIVER C********************************************************************* C* C* PROGRAM: This program 'cleans' entries off of a given queue. C* C* C* PURPOSE: This utility serves to ease the task of deleting multiple C* jobs from a queue when it is not desirable and/or possible C* to delete the whole queue. C* C* C* OPERATION: $ QCLEAN/LOG/CONFIRM/RANGE=(begin,end)/USER=(username) - C* queue_name C* C* C* ENVIRONMENT: VAX VMS V5.5-1 C* VAX Fortran 5.7 C* C* RESTRICTIONS: Must have standard VMS privileges to work with queues C* (i.e., OPER or delete access to the queue) C* C* Information America C* J. Wren Hunt C* June 11, 1990 C* C* MODIFICATION HISTORY: C* C* C*********************************************************************** external QCLEAN_table ! created by SET COMMAND/OBJECT integer*2 out_len ! length of user input integer*4 prompt_flag ! flag for LIB$GET_FOREIGN integer*4 sts$value ! return status value integer*4 cli$dispatch ! invoke QCLEAN function integer*4 cli$dcl_parse ! check QCLEAN syntax integer*4 lib$get_foreign ! get command from DCL line character*132 command_line ! input from user character*139 full_command ! input to CLI$DISPATCH prompt_flag = 0 ! don't prompt by default ************************************************************************** C C Mainline driver code follows... C *************************************************************************** *** C Get the command line the user specified. sts$value = lib$get_foreign(command_line,,out_len,prompt_flag) C Since it stripped off the 'verb', replace it back so that we can C call the CLI$DCL_PARSE routine full_command = 'QCLEAN ' // command_line C Let it determine which qualifiers & parameters were specified sts$value = cli$dcl_parse(full_command,QCLEAN_table,,,) C Now execute the command! sts$value = cli$dispatch() end ! QCLEAN_DRIVER integer*4 function QCLEAN_COMMAND() C********************************************************************* C* C* This routine does the actual processing for determining which jobs C* to 'clean' from the specified queue. C* C* C* J. Wren Hunt C* October 18, 1989 C* C********************************************************************** implicit none include '($clidef)' ! command language interpreter defs include '($ssdef)' ! system service status defs include '($quidef)' ! $GETQUIW status defs external cli$_present ! qualifier is present external cli$_defaulted ! qualifier present by default external cli$_absent ! qualifier is absent external QCLEAN_table ! table created by SET COMMAND/OBJECT logical log_flag logical all_flag logical confirm_flag logical range_flag logical user_flag integer*2 search_name_len, queue_name_len, job_name_len, 1 username_len integer*4 iosb(2) ! I/O Status Block values integer*4 cli$present ! Routine to determine if qualifier present integer*4 cli$get_value ! routine to get qualifier value integer*4 sts$value ! return status value integer*4 status_q ! queue operation return status integer*4 status_j ! job operation return status integer*4 last ! find last non-blank char in string integer*4 sys$getquiw ! get queue information integer*4 str$upcase ! convert lower -> uppercase integer*4 delete_entry ! internal function to zap queue entries integer*4 search_flags ! search flags for $GETQUI integer*4 job_size ! returned job size (in blocks) integer*4 job_status ! returned job status integer*4 entry_number ! returned job entry number integer*4 begin_range ! user-specified begin range integer*4 end_range ! user-specified end range character*1 answer ! user's answer to delete prompt character*5 begin_s,end_s ! string representation of begin/end character*12 username character*12 user_to_kill character*31 search_name character*31 queue_name character*39 job_name C+++++++++++++++++++++ C C RECORD Declarations C C+++++++++++++++++++++ structure /itmlst/ union map integer*2 buflen ! buffer length integer*2 itmcod ! item code integer*4 bufadr ! buffer address integer*4 retadr ! return address end map map integer*4 end_list ! terminate end-of-list with longword 0 end map end union end structure record /itmlst/ queue_list(4) record /itmlst/ job_list(7) common /stuff/username,user_to_kill,all_flag,user_flag,confirm_flag, 1 username_len 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*********************************************************** begin_range = 0 end_range = 0 C See what qualifiers the user specified... sts$value = cli$present('log') if (sts$value .eq. %loc(cli$_present) 1 .or. sts$value .eq. %loc(cli$_defaulted)) then log_flag = .true. else log_flag = .false. end if sts$value = cli$present('all') if (sts$value .eq. %loc(cli$_present)) then all_flag = .true. else all_flag = .false. end if sts$value = cli$present('confirm') if (sts$value .eq. %loc(cli$_present) 1 .or. sts$value .eq. %loc(cli$_defaulted)) then confirm_flag = .true. else confirm_flag = .false. end if c if (sts$value .eq. %loc(cli$_negated)) confirm_flag = .false. C See if user specified a range; if so, then get two values (1) begin & C (2) end job numbers sts$value = cli$present('range') if (sts$value .eq. %loc(cli$_present)) then range_flag = .true. sts$value = cli$get_value('range',begin_s) if (.not. sts$value) call lib$signal(%val(sts$value)) sts$value = cli$get_value('range',end_s) if (.not. sts$value) call lib$signal(%val(sts$value)) C Convert strings to numeric read (unit=begin_s(1:5),fmt='(bn,i10)') begin_range read (unit=end_s(1:5),fmt='(bn,i10)') end_range else range_flag = .false. end if sts$value = cli$present('USER') if (sts$value .eq. %loc(cli$_present)) then user_flag = .true. sts$value = cli$get_value('USER',user_to_kill) if (.not. sts$value) call lib$signal(%val(sts$value)) else user_flag = .false. end if C Grab the first parameter. Since this is a 'required' parameter, if it's C absent then we know the CLI has already given the user an error message C so just go ahead and quit til they get it right. sts$value = cli$get_value('queue_name',search_name) if (sts$value .eq. %loc(cli$_absent)) call exit search_name_len = last(search_name) c Initialize item list for the display queue operations queue_list(1).buflen = search_name_len queue_list(1).itmcod = qui$_search_name queue_list(1).bufadr = %loc(search_name) queue_list(1).retadr = 0 queue_list(2).buflen = 4 queue_list(2).itmcod = qui$_search_flags queue_list(2).bufadr = %loc(search_flags) queue_list(2).retadr = 0 queue_list(3).buflen = 31 queue_list(3).itmcod = qui$_queue_name queue_list(3).bufadr = %loc(queue_name) queue_list(3).retadr = %loc(queue_name_len) queue_list(4).end_list = 0 C Initialize item list for the display job operation job_list(1).buflen = 4 job_list(1).itmcod = qui$_search_flags job_list(1).bufadr = %loc(search_flags) job_list(1).retadr = 0 job_list(2).buflen = 4 job_list(2).itmcod = qui$_job_size job_list(2).bufadr = %loc(job_size) job_list(2).retadr = 0 job_list(3).buflen = 39 job_list(3).itmcod = qui$_job_name job_list(3).bufadr = %loc(job_name) job_list(3).retadr = %loc(job_name_len) job_list(4).buflen = 12 job_list(4).itmcod = qui$_username job_list(4).bufadr = %loc(username) job_list(4).retadr = %loc(username_len) job_list(5).buflen = 4 job_list(5).itmcod = qui$_job_status job_list(5).bufadr = %loc(job_status) job_list(5).retadr = 0 job_list(6).buflen = 4 job_list(6).itmcod = qui$_entry_number job_list(6).bufadr = %loc(entry_number) job_list(6).retadr = 0 job_list(7).end_list = 0 C The following is from the example in the System Services References Manual: C C "Request search of all jobs present in output queue; also force C wildcard mode to maintain the internal search context block after C the first call when a non-wild queue name is entered -- this preserves C queue context for the subsequent display job operation." C C Note that if QUI$M_SEARCH_SYMBIONT is specified, it will search only C print queues; it will not handle batch queues. Search_Flags = (qui$m_search_wildcard .or. 1 qui$m_search_all_jobs) C Dissolve any internal search context block for the process status_q = sys$getquiw(,%val(qui$_cancel_operation),,,,,) if (.not. status_q) call lib$signal(%val(status_q)) C Do a 'priming' read... status_q = sys$getquiw(,%val(qui$_display_queue),, 1 queue_list,iosb,,) if (.not. status_q) call lib$signal(%val(status_q)) if (.not. iosb(1)) call lib$signal(%val(iosb(1))) status_j = sys$getquiw(,%val(qui$_display_job),, 2 job_list,iosb,,) if (.not. status_j) call lib$signal(%val(status_j)) if (.not. iosb(1)) call lib$signal(%val(iosb(1))) if (status_j) status_j = iosb(1) do while (status_j) Got a job so see if user wants to delete it. if (range_flag .eq. .false. .and. user_flag .eq. .false.) then type 100,job_name(1:job_name_len),entry_number, 1 username(1:username_len) if (confirm_flag .eq. .true.) then read 200,answer c Convert user's input to uppercase for ease in comparing. sts$value = str$upcase(answer,answer) if (answer(1:1) .eq. 'Y') 1 call delete_entry(queue_name,entry_number,log_flag, 2 job_name(1:job_name_len),range_flag,begin_range,end_range) else ! user specified /NOCONFIRM call delete_entry(queue_name,entry_number,log_flag, 1 job_name(1:job_name_len),range_flag,begin_range,end_range) end if ! checking confirmation switch else call delete_entry(queue_name,entry_number,log_flag, 1 job_name(1:job_name_len),range_flag,begin_range,end_range) end if status_j = sys$getquiw(,%val(qui$_display_job),, 2 job_list,iosb,,) if (status_j) status_j = iosb(1) end do 100 format('$',a,4x,i4,4x,a' delete? [n]') 200 format(a1) qclean_command = ss$_normal ! always return back a good status end ! QCLEAN_COMMAND ! to CLI$DISPATCH subroutine delete_entry(queue_name, entry_number,log_flag, 1 job_name,range_flag,begin_range, 2 end_range) C************************************************************************* C C This routine does the actual deletion of the queue entry. C C C************************************************************************* implicit none include '($ssdef)' ! system service status defs include '($sjcdef)' ! $SNDJBCW status defs character*(*) queue_name,job_name logical log_flag logical range_flag logical all_flag logical user_flag logical confirm_flag logical deleted_flag integer*2k ! misc. scratch variable integer*2 username_len ! length of returned username integer*4 iosb(2) ! I/O Status block integer*4 entry_number ! returned job entry number integer*4 sts$value ! returned status value integer*4 sys$sndjbcw ! send-to-job-controller service integer*4 begin_range ! beginning range of jobs to delete integer*4 end_range ! ending range of jobs to delete integer*4 str$upcase ! convert lowercase -> uppercase integer*4 last ! find last non-blank char in string character*1 answer ! user's response to delete prompt character*12 username character*12 user_to_kill common /stuff/ username,user_to_kill,all_flag,user_flag,confirm_flag, 1 username_len C Got down here 'cause user wanted to blow away a print/batch job. Do it! structure /itmlst/ union map integer*2 buflen,itmcod integer*4 bufadr,retadr end map map integer*4 end_list end map end union end structure record /itmlst/ jbc_list(4) C Assume we won't delete it. We use this flag so that we know which ones to C print out if /LOG was requested. deleted_flag = .false. jbc_list(1).buflen = 31 jbc_list(1).itmcod = sjc$_queue jbc_list(1).bufadr = %loc(queue_name) jbc_list(1).retadr = 0 jbc_list(2).buflen = 4 jbc_list(2).itmcod = sjc$_entry_number jbc_list(2).bufadr = %loc(entry_number) jbc_list(2).retadr = 0 jbc_list(3).end_list = 0 C See if we're processing a range of jobs or just a single one. if (range_flag .eq. .true.) then if (entry_number .ge. begin_range .and. entry_number .le. end_range) then if (confirm_flag .eq. .true.) then type 100,job_name,entry_number,username read 200,answer sts$value = str$upcase(answer,answer) if (.not. sts$value) call lib$signal(%val(sts$value)) if (answer(1:1) .eq. 'Y') then sts$value = sys$sndjbcw(,%val(sjc$_delete_job),, 1 jbc_list,iosb,,) if (.not. sts$value) call lib$signal(%val(sts$value)) if (.not. iosb(1)) call lib$signal(%val(iosb(1))) if (iosb(1)) deleted_flag = .true. end if else sts$value = sys$sndjbcw(,%val(sjc$_delete_job),, 1 jbc_list,iosb,,) if (.not. sts$value) call lib$signal(%val(sts$value)) if (.not. iosb(1)) call lib$signal(%val(iosb(1))) if (iosb(1)) deleted_flag = .true. end if ! confirm_flag = true end if ! job is within specified range end if ! range_flag = true if (user_flag .eq. .true.) then k = last(user_to_kill) if (username(1:username_len) .eq. user_to_kill(1:k)) then if (confirm_flag .eq. .true.) then type 100,job_name,entry_number,username read 200,answer sts$value = str$upcase(answer,answer) if (.not. sts$value) call lib$signal(%val(sts$value)) if (answer(1:1) .eq. 'Y') then sts$value = sys$sndjbcw(, 1 %val(sjc$_delete_job),, 2 jbc_list,iosb,,) if (.not. sts$value) call lib$signal( 1 %val(sts$value)) if (.not. iosb(1)) call lib$signal(%val(iosb(1))) if (iosb(1)) deleted_flag = .true. end if else sts$value = sys$sndjbcw(,%val(sjc$_delete_job), 1 ,jbc_list,iosb,,) if (.not. sts$value) call lib$signal( 1 %val(sts$value)) if (.not. iosb(1)) call lib$signal(%val(iosb(1))) if (iosb(1)) deleted_flag = .true. end if ! confirm flag = true end if ! requested username matches user just found end if ! /USER= selected if (user_flag .eq. .false. .and. range_flag .eq. .false.) then sts$value = sys$sndjbcw(,%val(sjc$_delete_job),,jbc_list,iosb,,) if (.not. sts$value) call lib$signal(%val(sts$value)) if (.not. iosb(1)) call lib$signal(%val(iosb(1))) if (iosb(1)) deleted_flag = .true. end if C If user specified /LOG then tell them that it's a goner! if (log_flag .eq. .true. .and. deleted_flag .eq. .true.) 1 type 300,job_name,entry_number 100 format('$',a,4x,i4,4x,a' delete? [n]') 200 format(a1) 300 format('$','%QCLEAN-I-DELETED, ',a,4x,' entry ',i4,' deleted',/) end ! subroutine DELETE_ENTRY integer function last(string) C************************************************************************* C C This routine always finds the last non-blank character in a string and C returns it's position in the string. C C C************************************************************************* implicit none integer i character*(*) string i = len(string) do while (string(i:i) .eq. ' ') i = i - 1 end do last = i end! function LAST MODULE qclean_table define verb qclean routine qclean_command parameter p1, label=queue_name, prompt = "Queue" VALUE (REQUIRED) qualifier ALL qualifier CONFIRM default qualifier LOG default qualifier RANGE value (list) qualifier USER value (list) ! QCLEAN.HLP 1 QCLEAN Allows the user to remove selected jobs from print or batch queues without having to delete jobs individually. 2 /USER QCLEAN/USER=username queue_name Removes jobs from the specified queue which match the specified username. 2 /RANGE QCLEAN/RANGE=(start_range,end_range) queue_name Removes jobs from the start range through the end range inclusively, in the specified queue. 2 /LOG /NOLOG Specifies whether informational messages are printed/not printed when QCLEAN deletes queue entries. The default is /LOG. 2 /CONFIRM /NOCONFIRM Allows the user to verify/not verify individual queue entries before they are deleted. The default is /CONFIRM. 2 /ALL Specifies that ALL entries in the queue are to be deleted. 2 Examples $ QCLEAN/USER=HUNT SYS$BATCH In this example, all batch job entries in SYS$BATCH for user HUNT are deleted. By default, QCLEAN will ask for confirmation of job deletion. Printer queue TXA7, on SPLASH::, mounted form DEFAULT Jobname Username Entry Blocks Status ------- -------- ----- ------ ------ BATCH MITCHELL 275 3 Pending BATCH MITCHELL 276 3 Pending IAI HUNT 277 6 Pending CMS_VERIFY SORRELL 278 15 Pending SHOW_CLUSTER COBB 279 1 Pending QCLEAN HUNT 280 27 Pending BATCH HUNT 282 1 Pending BATCH HUNT 283 1 Pending BATCH HUNT 284 1 Pending BATCH HUNT 285 1 Pending BATCH HUNT 286 1 Pending BATCH HUNT 287 1 Pending QCLEAN/LOG/RANGE=(282,287)/NOCONFIRM TXA7: In this example, all job entries between the ranges of 282 & 287 are deleted with no confirmation on printer queue TXA7: