cancel_abs_request.pl1 08/21/90 1120.0rew 08/21/90 1118.7 601128 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ cancel_abs_request: car: procedure; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This is a 7 command procedure. It will cancel absentee, IO Daemon (eg, */ /* dprint/dpunch/plot), output (eg, enter_output_request), and retrieval requests from */ /* standard system queues. It will also move absentee requests from one queue to */ /* another or will move IO Daemon or output requests from one queue and request type to */ /* another. */ /* */ /* When the -user (or -admin) control argument is given, cancellations may be done */ /* for another user's requests and moves of another user's requests will use privileged */ /* message segment primitives which will preserve the original sender's identity. */ /* */ /****^ HISTORY COMMENTS: 1) change(71-09-17,Stone), approve(), audit(), install(): Modified by E. Stone. 2) change(73-02-01,Capps), approve(), audit(), install(): Modified by Dennis Capps to be cleverer about control seg name. 3) change(73-04-17,Coren), approve(), audit(), install(): Modified by Robert Coren to work on io_daemon queues. 4) change(74-09-12,Stern), approve(), audit(), install(): Modified by J. Stern to use message_segment_ "index" entries. 5) change(75-06-24,Stern), approve(), audit(), install(): Modified by J. Stern. 6) change(76-04-15,Herbst), approve(), audit(), install(): Modified by Steve Herbst. 7) change(76-12-28,VanVleck), approve(), audit(), install(): Modified by THVV. 8) change(77-01-05,Vinograd), approve(), audit(), install(): Modified by D. Vinograd to add entries cancel_retrieval_request and test_crr. 9) change(78-05-01,Whitmore), approve(), audit(), install(): Rewritten by J. C. Whitmore to add the move entries and several control args. 10) change(78-12-01,Whitmore), approve(), audit(), install(): Modified to recognize abs queue 0 and foreground queue. 11) change(79-01-01,Whitmore), approve(), audit(), install(): Modified to add as_abs subroutine entry and -sender arg to abs entries. 12) change(80-04-01,Whitmore), approve(), audit(), install(): Modified to warn user when daemon request is running. 13) change(80-09-01,Palter), approve(), audit(), install(): Modified by G. Palter to provide site-settable default absentee queues. 14) change(82-01-01,GDixon), approve(), audit(), install(): Modified by G. Dixon to support eor's user defined request types, and to add -print, -punch, -plot. 15) change(84-07-01,Marker), approve(), audit(), install(): Modified by C. Marker to search all queues by default. 16) change(84-10-11,Margulies), approve(), audit(), install(): Modified by BIM for mseg_message_info 17) change(85-12-13,Lippard), approve(85-12-30,MCR7326), audit(86-10-27,GDixon), install(86-10-28,MR12.0-1200): Modified by Jim Lippard to use send_as_request_ instead of hcs_$wakeup. 18) change(87-07-07,GDixon), approve(87-07-07,MCR7741), audit(87-07-07,Hartogs), install(87-08-04,MR12.1-1055): Include user_abs_attributes.incl.pl1 as part of splitting abs_message_format.incl.pl1. 19) change(87-07-16,Lippard), approve(87-11-04,MCR7762), audit(87-11-04,Fawcett), install(87-11-30,MR12.2-1006): Modified to stop munging sender_id. 20) change(90-06-20,Huen), approve(90-06-20,MCR8179), audit(90-07-17,Itani), install(90-08-21,MR12.4-1025): IO_Daemons_79: Change cancel_output_request and cancel_daemon_request so that if a request is already running to not delete it from the queue. END HISTORY COMMENTS */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl MATCH_ID char (20); /* global match id for all requests */ dcl admin_sw bit (1); dcl all_sw bit (1); dcl alp ptr; dcl answer char (16) var; dcl areap ptr; dcl arg_did_match bit (1); dcl arg_didnt_match bit (1); dcl arg_dir_dir char (168); dcl arg_dir_ent char (32); dcl arg_no fixed bin; dcl arglen fixed bin; dcl argptr ptr; dcl bad_msg_version bit (1); dcl brief_sw bit (1); dcl call_sys_log bit (1); dcl code fixed bin (35); dcl default_q fixed bin; dcl dir char (168); dcl end_msg_seg bit (1); dcl entry fixed bin; /* see named constants below. */ dcl entry_id_count fixed bin; dcl first_arg fixed bin; dcl first_q fixed bin; dcl found_all_arg_match bit (1); dcl found_one_match bit (1); dcl gen_type char (32); dcl id char (28); dcl id_match_ms_id bit (72) aligned; dcl id_msg char (32) var; dcl idx fixed bin; dcl input_seg char (32); dcl last_q fixed bin; dcl len fixed bin; dcl long_msg char (256); /* expanded error message from ioa_$rsnnl */ dcl max_q fixed bin; dcl mode bit (36) aligned; dcl mseg_idx (-1:4) fixed bin; /* mseg index for queues with existing requests */ dcl mseg_name char (32); dcl mseg_sender_id char (32); dcl msg char (136); /* error message, long as one print line */ dcl msg_id_code fixed bin (71); /* this is a clock reading actually */ dcl nargs fixed bin; dcl old_ms_id bit (72) aligned; dcl one_request_only bit (1); dcl option char (32); dcl path_id_count fixed bin; dcl person char (28); dcl project char (28); dcl queue_no fixed bin; dcl queue_pic pic "9"; /* for converting queue number to char */ dcl queue_sw bit (1); dcl queue_type char (32); dcl rdir char (168); dcl req_dir_dir char (168); dcl req_dir_ent char (32); dcl req_dir_uid bit (36); dcl reqp ptr; dcl request_id_count fixed bin; dcl rqt_sw bit (1); dcl rseg char (32); dcl saved_code fixed bin (35) init (0); dcl search_all_sw bit (1); dcl sender char (32); dcl sender_id char (32); dcl sender_sw bit (1); dcl single_ms_id bit (72) aligned; dcl sysdir char (168); dcl target_default_q fixed bin; dcl target_gen_type char (32); dcl target_max_q fixed bin; dcl target_mseg_idx fixed bin; /* mseg index of target queue of a move */ dcl target_queue fixed bin; dcl target_queue_type char (32); dcl to_q_sw bit (1); dcl to_rqt_sw bit (1); dcl try_again bit (1); dcl user char (32); dcl verb char (8); dcl wakeup_answering_service bit (1); dcl 1 br aligned, 2 padding (9) bit (36), 2 uid bit (36); dcl 1 local_asraci aligned like asr_abs_command_info; dcl 1 local_mseg_message_info like mseg_message_info aligned; dcl arg char (arglen) unaligned based (argptr); dcl CAR fixed bin int static options (constant) init (1); /* values assigned to the entry variable */ dcl CDR fixed bin int static options (constant) init (2); dcl COR fixed bin int static options (constant) init (3); dcl CRR fixed bin int static options (constant) init (4); dcl MAR fixed bin int static options (constant) init (5); dcl MDR fixed bin int static options (constant) init (6); dcl MOR fixed bin int static options (constant) init (7); dcl ASC fixed bin int static options (constant) init (8); /* AS_CANCEL entry code */ dcl ASM fixed bin int static options (constant) init (9); /* AS_MOVE entry code */ dcl ASN fixed bin int static options (constant) init (10); /* AS_NEXT entry code */ dcl PATH fixed bin static options (constant) init (1); /* values assigned to type array (dcl in begin block) */ dcl ENTRY fixed bin static options (constant) init (2); dcl ID fixed bin static options (constant) init (3); dcl ID_CHARS char (11) int static options (constant) init ("0123456789."); dcl CAPS char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl Q_name (-1:4) char (16) int static options (constant) init ("foreground queue", "queue 1", "queue 1", "queue 2", "queue 3", "queue 4"); dcl abs_default_q fixed bin int static; dcl abs_max_q fixed bin int static; dcl abs_sysdir char (168) internal static init (">system_control_1"); dcl io_default_q fixed bin int static; dcl io_max_q fixed bin int static; dcl iod_sysdir char (168) int static init (">daemon_dir_dir>io_daemon_dir"); dcl not_initialized bit (1) int static init ("1"b); dcl ret_default_q fixed bin int static; dcl ret_max_q fixed bin int static; dcl retriever_sysdir char (168) int static init (">daemon_dir_dir>volume_retriever"); dcl (cleanup, conversion, linkage_error, size) condition; dcl re_read_label label; /* where to go to try reading again */ dcl error_table_$bad_arg ext fixed bin (35); dcl error_table_$bad_conversion ext fixed bin (35); dcl error_table_$bad_segment ext fixed bin (35); dcl error_table_$badopt ext fixed bin (35); dcl error_table_$id_not_found ext fixed bin (35); dcl error_table_$no_message ext fixed bin (35); dcl error_table_$noarg ext fixed bin (35); dcl error_table_$request_pending ext fixed bin (35); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl check_star_name_$path entry (char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl command_query_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl enter_output_request$default_request_type entry (char (*), char (*), fixed bin, fixed bin, fixed bin (35)); dcl enter_output_request$request_type entry (char (*), char (*), char (*), fixed bin, fixed bin, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry (ptr); dcl hcs_$star_ entry (char (*), char (*), fixed bin, ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl (ioa_, ioa_$rsnnl) entry options (variable); dcl iod_info_$generic_type entry (char (*), char (32), fixed bin (35)); dcl iod_info_$queue_data entry (char (*), fixed bin, fixed bin, fixed bin (35)); dcl iod_info_$test entry (char (*)); dcl match_request_id_ entry (fixed bin (71), char (*)) returns (bit (1) aligned); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl message_segment_$add_index entry (fixed bin, ptr, fixed bin (24), bit (72) aligned, fixed bin (35)); dcl message_segment_$close entry (fixed bin, fixed bin (35)); dcl message_segment_$delete_index entry (fixed bin, bit (72) aligned, fixed bin (35)); dcl message_segment_$get_mode_index entry (fixed bin, bit (36) aligned, fixed bin (35)); dcl message_segment_$open entry (char (*), char (*), fixed bin, fixed bin (35)); dcl message_segment_$read_message_index entry (fixed bin, ptr, ptr, fixed bin (35)); dcl queue_admin_$add_index entry (fixed bin, ptr, bit (72) aligned, fixed bin (35)); dcl request_id_ entry (fixed bin (71)) returns (char (19)); dcl send_as_request_$no_block entry (ptr, fixed bin, bit (72) aligned, fixed bin (35)); dcl suffixed_name_$make entry (char (*), char (*), char (*), fixed bin (35)); dcl sys_log_$error_log entry options (variable); dcl system_info_$default_absentee_queue entry (fixed bin); dcl (addr, after, before, currentsize, min, null, substr, rtrim, convert, unspec, verify, search, length) builtin; %page; %include abs_message_format; %page; %include as_request_header; %page; %include asr_abs_command; %page; %include dprint_msg; %page; %include mseg_message_info; %page; %include query_info_; %page; %include queue_msg_hdr; %page; %include retv_request; %page; %include user_abs_attributes; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* cancel_abs_request: car: entry; Main entry point. */ if not_initialized then call init; id = "cancel_abs_request"; sysdir = abs_sysdir; default_q = abs_default_q; max_q = abs_max_q; queue_type = "absentee"; entry = CAR; go to cmd_common; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ cancel_daemon_request: cdr: entry; /* This entry performs same functions as main entry but uses io_daemon request queues (dprint/dpunch/dplot) */ if not_initialized then call init; id = "cancel_daemon_request"; sysdir = iod_sysdir; default_q = io_default_q; max_q = io_max_q; queue_type, gen_type = "printer"; entry = CDR; go to cmd_common; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ cancel_output_request: cor: entry; /* This entry performs same functions as main entry but uses io_daemon request queues (enter_output_request) */ if not_initialized then call init; id = "cancel_output_request"; sysdir = iod_sysdir; gen_type = "printer"; call enter_output_request$default_request_type (gen_type, queue_type, default_q, max_q, code); entry = COR; go to cmd_common; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ cancel_retrieval_request: crr: entry; /* This entry performs the same function as the main entry but uses retrieval request queues */ if not_initialized then call init; id = "cancel_retrieval_request"; sysdir = retriever_sysdir; default_q = ret_default_q; max_q = ret_max_q; queue_type = "volume_retriever"; entry = CRR; go to cmd_common; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ move_abs_request: mar: entry; /* This entry will move an absentee request from one queue to another */ if not_initialized then call init; id = "move_abs_request"; sysdir = abs_sysdir; default_q = abs_default_q; max_q = abs_max_q; queue_type = "absentee"; entry = MAR; go to cmd_common; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ move_daemon_request: mdr: entry; /* This entry will move a dprint/dpunch/dplot request from one rqt/queue to another */ if not_initialized then call init; id = "move_daemon_request"; sysdir = iod_sysdir; default_q = io_default_q; max_q = io_max_q; queue_type, gen_type = "printer"; /* default to the printer queues */ entry = MDR; go to cmd_common; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ move_output_request: mor: entry; /* This entry will move an enter_output_request from one rqt/queue to another */ if not_initialized then call init; id = "move_output_request"; sysdir = iod_sysdir; gen_type = "printer"; /* default to the printer queues */ call enter_output_request$default_request_type (gen_type, queue_type, default_q, max_q, code); entry = MOR; go to cmd_common; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ as_abs: entry (a_arglp, a_nargs, a_req_id_ret, a_code); /* this entry is ONLY for the answering service "abs move", "abs cancel", and "abs next" commands */ dcl a_arglp ptr; /* arg list ptr from abs xxx command - including the xxx */ dcl a_nargs fixed bin; /* number of args in abs xxx arg list */ dcl a_req_id_ret fixed bin (71); /* request id which we did xxx to */ dcl a_code fixed bin (35); /* you guessed it! */ if not_initialized then call init; alp = a_arglp; /* copy the arg list pointer */ a_req_id_ret = 0; /* clear the value for now */ a_code = 0; call cu_$arg_ptr_rel (1, argptr, arglen, a_code, alp); /* see which this is */ if a_code ^= 0 then return; if arg = "cancel" then entry = ASC; /* the abs cancel entry */ else if arg = "move" then entry = ASM; /* " abs move */ else if arg = "next" then entry = ASN; /* " abs next */ else do; /* undefined function */ a_code = error_table_$bad_arg; return; end; queue_type = "absentee"; max_q = abs_max_q; default_q = abs_default_q; sysdir = abs_sysdir; id = "cancel_abs_request$as_abs"; nargs = a_nargs; /* copy the number of args given */ call_sys_log = "1"b; /* for the as_abs entry write errors to sys_log */ go to common; /* now join the command code */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ cmd_common: call cu_$arg_count (nargs, code); /* get number of args for allocating variables in begin block */ if code ^= 0 then do; call com_err_ (code, id); return; end; call cu_$arg_list_ptr (alp); /* get arglist ptr so begin block can get args */ call_sys_log = "0"b; /* for commands we use the standard com_err_ */ common: brief_sw, /* initialize switches to zero */ admin_sw, sender_sw, all_sw, rqt_sw, queue_sw, to_q_sw, to_rqt_sw, wakeup_answering_service, search_all_sw = "0"b; /* default - look for callers own requests */ request_id_count, path_id_count, entry_id_count = 0; MATCH_ID = ""; /* clear the global match id for all requests */ person, project, sender = ""; if (entry = ASN | entry = ASC) then one_request_only = "1"b; else one_request_only = "0"b; /* match multiple requests unless ASN or ASC */ mseg_idx (*) = 0; /* no message segments open yet */ target_mseg_idx = 0; reqp = null; BLOCK: begin; /* allocate adjustable storage. */ dcl arg_dir_uid (nargs) bit (36); dcl matched (nargs) fixed bin; /* matched (i) is number of requests matching arg i */ dcl msg_id (nargs) bit (72) aligned; /* message id of matched request */ dcl queue (nargs) fixed bin; /* queue where request is (if not starname) */ dcl req_seg (nargs) char (32); /* entry name of segment in request for arg i */ dcl starname (nargs) fixed bin; /* 0 = no star, 1 = normal star, 2 = double star */ dcl type (nargs) fixed bin; /* type of request identifier for arg i */ /* 1 = PATH, 2 = ENTRY name, 3 = ID number */ dcl used_up (nargs) bit (1) unal; /* bit i TRUE if arg i to be ignored later */ arg_dir_uid (*) = ""b; matched (*) = 0; msg_id (*) = ""b; queue (*) = 0; req_seg (*) = ""; starname (*) = 0; type (*) = 0; used_up (*) = "0"b; target_queue, first_q, last_q = -10; /* init to illegal values */ target_default_q = default_q; /* define in case of bad iod_tables */ target_max_q = max_q; first_arg = 1; /* start inital arg pass at arg 1, unless redefined */ on conversion begin; code = error_table_$bad_conversion; msg = "Illegal value for argument: " || option; go to abort_cmd; /* abort now */ end; on size begin; code = error_table_$bad_conversion; msg = "Value out of range for argument: " || option; go to abort_cmd; end; /* Start of first pass over the arguments. Locate request identifiers and check control args */ if entry = ASM | entry = ASC | entry = ASN then do; /* special case the as_abs entries */ used_up (1) = "1"b; /* first arg was cancel, move, or next */ len = min (nargs, 4); /* look at up to 3 more here */ do arg_no = 2 to len while (first_arg = 1); /* next args are user, proj and/or ID without ctl arg */ /* allowable forms are and */ /* where is pers.proj or "pers proj" */ /* any ctl arg terminates free form input */ call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if code ^= 0 then do; msg = "First args assumed to be user and request id."; go to abort_cmd; end; /* terminate on ctl arg or full path */ if substr (arg, 1, 1) = "-" | substr (arg, 1, 1) = ">" then first_arg = arg_no; else if verify (arg, ID_CHARS) = 0 then do; /* this must be a request id */ type (arg_no) = ID; /* mark it as an request id for later */ request_id_count = request_id_count + 1; /* say we have one */ one_request_only = "1"b; /* Opr will only give one id */ end; else if person = "" then do; /* not ctl arg or ID, must be user name */ used_up (arg_no) = "1"b; /* don't look at this again */ admin_sw = "1"b; /* say we have a user name */ search_all_sw = "1"b; /* don't look at just our own requests */ sender_id = arg; person = before (sender_id, "."); project = before (after (sender_id, "."), "."); if length (rtrim (person)) > 22 | search (substr (person, 1, 1), CAPS) = 0 then do; msg = "Invalid person name: " || person; go to abort_cmd; end; if project = "" then do; /* try for "pers proj" form */ call cu_$arg_ptr_rel (arg_no + 1, argptr, arglen, code, alp); /* peek at next arg */ if code ^= 0 then first_arg = arg_no + 1; /* we may be done */ else if length (arg) <= 9 & search (substr (arg, 1, 1), CAPS) ^= 0 then do; project = arg; /* if it looks like a project name, use it */ arg_no = arg_no + 1; /* found it, advance index */ used_up (arg_no) = "1"b; end; end; end; else first_arg = arg_no; /* not an id or pers/proj */ end; if first_arg = 1 then first_arg = arg_no; /* if no ctl arg, go on with 4 */ if person ^= "" then if project = "" then project = "*"; /* no proj use * */ if entry = ASN then do; /* for the abs next cmd we move the request into q 0 */ to_q_sw = "1"b; /* mark as pre specified */ target_queue = 0; /* this is the head of q 1 */ end; end; do arg_no = first_arg to nargs; if used_up (arg_no) then go to next_option; msg = ""; /* clear error message string */ call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if code ^= 0 then do; msg = "Argument read error."; /* check the codes first time around only */ go to abort_cmd; end; if substr (arg, 1, 1) = "-" then do; /* look for all allowable options */ used_up (arg_no) = "1"b; option = arg; /* save for better error messages */ if option = "-admin" | option = "-am" | option = "-user" then do; arg_no = arg_no + 1; call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if code ^= 0 | substr (arg, 1, 1) = "-" then do; msg = "No user name given with argument: " || option; go to abort_cmd; end; used_up (arg_no) = "1"b; if admin_sw then do; msg = "Only one user name allowed. " || option; go to abort_cmd; end; admin_sw = "1"b; /* say we have a user name */ search_all_sw = "1"b; /* look at all requests in the queues */ sender_id = arg; /* copy argument */ person = before (sender_id, "."); project = before (after (sender_id, "."), "."); if person = "" then person = "*"; if project = "" then project = "*"; if (entry = ASC | entry = ASM | entry = ASN) & person = "*" then do; msg = "A user name other then ""*"" or blank must be given."; go to abort_cmd; end; end; else if option = "-brief" | option = "-bf" then brief_sw = "1"b; /* say brief option given */ else if option = "-all" | option = "-a" then all_sw = "1"b; /* say all option given */ else if option = "-queue" | option = "-q" then do; if queue_sw then do;/* duplicate option? */ msg = "Duplicate queue specification argument: " || option; go to abort_cmd; end; arg_no = arg_no + 1;/* get next argument - queue number */ call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if code ^= 0 | substr (arg, 1, 1) = "-" then do; msg = "Queue number missing."; go to abort_cmd; end; used_up (arg_no) = "1"b; if (entry = CAR | entry = MAR | entry = ASC | entry = ASM | entry = ASN) & (arg = "fg" | arg = "foreground") then queue_no = -1; else queue_no = convert (queue_no, arg); /* change to fixed bin */ if ((entry = MAR | entry = CAR | entry = ASC | entry = ASM | entry = ASN) & queue_no < -1) | ((entry = MDR | entry = MOR | entry = CDR | entry = COR | entry = CRR) & queue_no < 1) | queue_no > 4 then do; msg = "Invalid queue: " || arg; go to abort_cmd; end; queue_sw = "1"b; /* indicate queue option given */ first_q, last_q = queue_no; end; else if (entry = CAR | entry = MAR | entry = ASC | entry = ASM | entry = ASN) & (option = "-foreground" | option = "-fg") then do; if queue_sw then do;/* duplicate option? */ msg = "Duplicate queue specification argument: " || option; go to abort_cmd; end; used_up (arg_no) = "1"b; queue_no = -1; queue_sw = "1"b; /* indicate queue option given */ first_q, last_q = queue_no; end; else if (entry = CAR | entry = MAR | entry = ASC | entry = ASM | entry = ASN) & option = "-sender" then do; if sender_sw then do; msg = "Duplicate control argument: " || option; go to abort_cmd; end; arg_no = arg_no + 1; call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if code ^= 0 | substr (arg, 1, 1) = "-" then do; msg = "Sender name missing."; go to abort_cmd; end; used_up (arg_no) = "1"b; sender_sw = "1"b; sender = arg; end; else if (entry = CDR | entry = COR | entry = MDR | entry = MOR) & /* I/O Daemon request types */ (option = "-rqt" | option = "-request_type") then do; if rqt_sw then do; /* duplicate option? */ msg = "Duplicate control argument: " || option; go to abort_cmd; end; arg_no = arg_no + 1; call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if code ^= 0 | substr (arg, 1, 1) = "-" then do; msg = "Request type name missing."; go to abort_cmd; end; used_up (arg_no) = "1"b; if (entry = CDR | entry = MDR) then do; call iod_info_$generic_type (arg, gen_type, code); if code ^= 0 then if code = error_table_$id_not_found then do; msg = "Unknown request type: " || arg; go to abort_cmd; end; else call err_proc (-1, 0, "Warning -- Unable to check request type ^a.", arg); else do; call iod_info_$queue_data (arg, default_q, max_q, code); if code ^= 0 then do; msg = "Unable to get default and max queues for: " || arg; go to abort_cmd; end; end; queue_type = arg; end; else do; /* must use enter_output_request to process */ /* request types for COR and MOR */ call enter_output_request$request_type (arg, gen_type, queue_type, default_q, max_q, code); if code ^= 0 then if code = error_table_$id_not_found then do; msg = "Unknown request type: " || arg; go to abort_cmd; end; else call err_proc (-1, 0, "Warning -- Unable to check request type ^a.", arg); end; rqt_sw = "1"b; /* say we got this arg */ end; else if (entry = MAR | entry = MDR | entry = MOR | entry = ASM) & (option = "-to_queue" | option = "-tq" | option = "-to_q") then do; /* these recognize the -tq option */ if to_q_sw then do; /* duplicate option? */ msg = "Duplicate control argument: " || option; go to abort_cmd; end; arg_no = arg_no + 1;/* get next argument - queue number */ call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if code ^= 0 | substr (arg, 1, 1) = "-" then do; msg = "Queue number missing for: " || option; go to abort_cmd; end; used_up (arg_no) = "1"b; if (entry = MAR | entry = ASM) & (arg = "fg" | arg = "foreground") then queue_no = -1; else queue_no = convert (queue_no, arg); /* change to fixed bin */ if ((entry = MAR | entry = ASM) & queue_no < -1) | ((entry = MDR | entry = MOR) & queue_no < 1) | queue_no > 4 then do; msg = "Invalid queue number: " || arg; go to abort_cmd; end; target_queue = queue_no; to_q_sw = "1"b; end; else if (entry = MDR | entry = MOR) & (option = "-to_request_type" | option = "-to_rqt") then do; /* only MDR and MOR know about other request types */ if to_rqt_sw then do; /* duplicate option? */ msg = "Duplicate control argument: " || option; go to abort_cmd; end; arg_no = arg_no + 1; call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if code ^= 0 | substr (arg, 1, 1) = "-" then do; msg = "Request type name missing for: " || option; go to abort_cmd; end; used_up (arg_no) = "1"b; if entry = MDR then do; call iod_info_$generic_type (arg, target_gen_type, code); if code ^= 0 then if code = error_table_$id_not_found then do; msg = "Unknown request type: " || arg; go to abort_cmd; end; else call err_proc (-1, 0, "Warning -- Unable to check request type ^a.", arg); else do; call iod_info_$queue_data (arg, target_default_q, target_max_q, code); if code ^= 0 then do; msg = "Unable to get default and max queues for: " || arg; go to abort_cmd; end; end; target_queue_type = arg; end; else do; call enter_output_request$request_type (arg, target_gen_type, target_queue_type, target_default_q, target_max_q, code); if code ^= 0 then if code = error_table_$id_not_found then do; msg = "Unknown request type: " || arg; go to abort_cmd; end; else call err_proc (-1, 0, "Warning -- Unable to check request type ^a.", arg); end; to_rqt_sw = "1"b; end; else if (entry = COR | entry = MOR) & (option = "-print" | option = "-pr") then do; gen_type = "printer"; call enter_output_request$default_request_type (gen_type, queue_type, default_q, max_q, code); if code ^= 0 then do; msg = "^/Default request type for printing unknown"; go to abort_cmd; end; end; else if (entry = COR | entry = MOR) & (option = "-punch" | option = "-pch") then do; gen_type = "punch"; call enter_output_request$default_request_type (gen_type, queue_type, default_q, max_q, code); if code ^= 0 then do; msg = "^/Default request type for punching unknown"; go to abort_cmd; end; end; else if (entry = COR | entry = MOR) & (option = "-plot") then do; gen_type = "plotter"; call enter_output_request$default_request_type (gen_type, queue_type, default_q, max_q, code); if code ^= 0 then do; msg = "^/Default request type for plotting unknown"; go to abort_cmd; end; end; else if option = "-id" then do; /* we have a request ID type identifier */ arg_no = arg_no + 1; call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if code ^= 0 then do; msg = "Request match id missing for: " || option; go to abort_cmd; end; if verify (arg, ID_CHARS) ^= 0 then do; msg = "Invalid request id: " || arg; go to abort_cmd; end; type (arg_no) = ID; /* say this was given by id number */ request_id_count = request_id_count + 1; if request_id_count = 1 then MATCH_ID = arg; /* save the global value */ else MATCH_ID = ""; /* kill it if more than one */ if entry = ASM then one_request_only = "1"b; /* an id means only one */ end; else if option = "-entry" | option = "-et" then do; /* also a segment identifier */ arg_no = arg_no + 1; call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if code ^= 0 then do; msg = "Entry name missing for: " || option; go to abort_cmd; end; type (arg_no) = ENTRY; entry_id_count = entry_id_count + 1; end; else do; /* Illegal option */ code = error_table_$badopt; msg = option; go to abort_cmd; end; end; /* Not a control argument, must be a full or relative pathname */ else do; if (entry = ASM | entry = ASC | entry = ASN) & substr (arg, 1, 1) ^= ">" then do; msg = "Not a full pathname: " || arg; go to abort_cmd; end; type (arg_no) = PATH; /* this one is a pathname */ path_id_count = path_id_count + 1; end; next_option: end; /* All the control arguments and pathnames passed the first test. Now check for consistency */ if (request_id_count + path_id_count + entry_id_count) = 0 then do; /* Need at least one thing to cancel */ code = error_table_$noarg; /* .. of course we could interpret this as cancel all */ msg = "No request identifiers given."; abort_cmd: call err_proc (-1, code, msg, ""); if (entry = ASC | entry = ASM | entry = ASN) then if code = 0 then a_code = error_table_$bad_arg; /* be sure caller knows */ else a_code = code; return; end; if request_id_count > 1 then /* for multiple -id args */ if (path_id_count + entry_id_count) > 0 then do; /* can't have path or entry args */ code = error_table_$bad_arg; msg = "Multiple -id args are incompatible with path or entry args."; go to abort_cmd; end; else if one_request_only then do; /* this is bad too */ code = error_table_$bad_arg; msg = "Multiple -id args are not allowed."; go to abort_cmd; end; code = 0; if (entry = ASM | entry = ASC | entry = ASN) & ^admin_sw then do; code = error_table_$noarg; msg = "No user name specified."; go to abort_cmd; end; if ^to_rqt_sw then do; /* if no target specified, assume the same queue type */ target_queue_type = queue_type; target_default_q = default_q; target_max_q = max_q; target_gen_type = gen_type; end; else if target_queue_type = queue_type then to_rqt_sw = "0"b; /* same queue type */ if all_sw & queue_sw then do; /* all and queue are incompatible */ msg = "The -all and -queue control arguments are incompatible."; go to abort_cmd; end; if (entry = MAR | entry = ASM) & ^to_q_sw then do; msg = "Target queue for move not specified."; go to abort_cmd; end; if target_queue = -10 then target_queue = target_default_q; /* assume default if not set */ if ^queue_sw then all_sw = "1"b; if one_request_only then brief_sw = "1"b; /* if searching all Q's for one request */ if all_sw then do; /* define the queues to search */ if (entry = MAR | entry = CAR | entry = ASC | entry = ASM) then first_q = -1; else first_q = 1; last_q = max_q; end; else if ^queue_sw then first_q, last_q = default_q; /* use default if he didn't say */ if last_q > max_q then do; msg = "Specified queue number is greater than maximum for: " || queue_type; go to abort_cmd; end; if queue_sw & /* if queue was given, check more */ queue_type = "absentee" then do; /* do we treat queue 0 and 1 as the same */ if (entry = MAR | entry = ASM | entry = ASN) & first_q = target_queue then go to same_q; if first_q = 1 then first_q = 0; /* he asked for 1, we look at 0 and 1 */ end; /* done with absentee stuff */ if (entry = MDR | entry = MOR) & ^to_rqt_sw & first_q = last_q & target_queue = first_q then do; /* same queue??? */ same_q: msg = "The same queue specified as source and target of move."; go to abort_cmd; end; if (entry = MDR | entry = MOR) & (target_gen_type ^= gen_type) then do; /* cross types? */ msg = "The target request type of move is not of the same generic type as the source."; go to abort_cmd; end; if to_q_sw then /* if moving, is the target defined? */ if target_queue > target_max_q then do; msg = "Target queue number of move is greater than maximum for: " || target_queue_type; go to abort_cmd; end; if entry = MAR | entry = MDR | entry = MOR | entry = ASM | entry = ASN then verb = "move"; else verb = "cancel"; /* make messages clearer */ if admin_sw then user = rtrim (person) || "." || project; else user = "*.*"; /* this will just format query message correctly */ /* Check for valid star names in entry and path identifiers */ do arg_no = 1 to nargs; if ^used_up (arg_no) & type (arg_no) ^= ID then do; /* look at PATH and ENTRY args */ call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if type (arg_no) = PATH then do; /* get the directory uid while we are here */ call expand_pathname_ (arg, dir, input_seg, code); if code ^= 0 then do; no_exp: msg = "Unable to expand pathname for: " || arg; go to abort_cmd; end; call expand_pathname_ (dir, arg_dir_dir, arg_dir_ent, code); if code ^= 0 then go to no_exp; /* Get the unique id of the directory containing the segment so can still find it if path spelled differently */ call hcs_$status_long (arg_dir_dir, arg_dir_ent, 1, addr (br), null, code); if code = 0 then arg_dir_uid (arg_no) = br.uid; end; else dir = ""; /* avoid garbage */ call check_star_name_$path (arg, code); /* segment name or starname */ if code > 2 then do; /* bad star name, forget it */ used_up (arg_no) = "1"b; call err_proc (-1, code, "Argument ^a skipped.", arg); go to skip; end; if code ^= 0 & one_request_only then do; code = error_table_$bad_arg; msg = "Starnames are not allowed by this command or with ""-id"" control argument."; go to abort_cmd; end; starname (arg_no) = code; /* record the name type */ if code = 2 then do; /* double star, be sure caller wants this */ answer = ""; query_info.version = query_info_version_4; query_info.yes_or_no_sw = "1"b; query_info.suppress_name_sw = "1"b; call ioa_$rsnnl ("^[your ^]requests^[ for ^a^;^s^]^[ from directory ^a^;^s^]", msg, len, ^admin_sw, (user ^= "*.*"), user, (type (arg_no) = PATH), dir); call command_query_ (addr (query_info), answer, id, "Do you want to ^a all ^a ^[in all ^a queues^;in ^a ^a^]?", verb, msg, all_sw, queue_type, Q_name (last_q)); if answer ^= "yes" then do; used_up (arg_no) = "1"b; /* skip this one in the future */ go to skip; end; end; end; else if ^used_up (arg_no) then if ((path_id_count + entry_id_count) > 0) & MATCH_ID ^= "" then used_up (arg_no) = "1"b; /* special case the use of -id N alone, otherwise this was the MATCH_ID source */ skip: end; /* if move command, open target queue */ if entry = MAR | entry = MDR | entry = MOR | entry = ASM then do; if target_queue < 0 then mseg_name = rtrim (target_queue_type) || "_foreground.ms"; /* a -1 is the foreground queue */ else do; /* otherwise convert the queue number */ queue_pic = target_queue;/* convert number to char */ mseg_name = rtrim (target_queue_type) || "_" || queue_pic || ".ms"; end; call message_segment_$open (sysdir, mseg_name, target_mseg_idx, code); if code ^= 0 then do; call err_proc (1, code, "Unable to open target message segment: ^a", rtrim (sysdir) || ">" || mseg_name); return; end; end; call get_system_free_area_ (areap); /* get pointer to area - place to read message into */ mseg_message_info_ptr = addr (local_mseg_message_info); unspec (mseg_message_info) = ""b; mseg_message_info.version = MSEG_MESSAGE_INFO_V1; on cleanup call cleaner_up; queue_no = first_q; /* set value of first queue to be searched */ try_again = "1"b; /* try_again if salvaged mseg */ id_match_ms_id, single_ms_id = "0"b; found_one_match, found_all_arg_match = "0"b; queue_loop: /* construct entry name of message segment */ if queue_no < 0 then mseg_name = rtrim (queue_type) || "_foreground.ms"; else do; queue_pic = queue_no; /* convert number to char */ mseg_name = rtrim (queue_type) || "_" || queue_pic || ".ms"; end; /* open message segment containing requests */ call message_segment_$open (sysdir, mseg_name, mseg_idx (queue_no), code); if code ^= 0 then do; message_error: if code ^= error_table_$no_message then call err_proc (1, code, "^a", mseg_name); end_msg_seg = "1"b; /* indicate that this mseg is done */ try_again = "1"b; /* ready for next one */ go to next_msg; /* free request and go on to next queue or phase */ end; if to_q_sw & target_mseg_idx = mseg_idx (queue_no) then do; end_msg_seg = "1"b; /* don't search target queue for match on -all */ go to next_msg; end; call message_segment_$get_mode_index (mseg_idx (queue_no), mode, code); if code ^= 0 then do; call err_proc (-1, code, "Unable to check user's mode to message segment ^a.", mseg_name); end_msg_seg = "1"b; go to next_msg; end; if admin_sw then do; /* process must have read and delete access */ if (mode & "01100"b) ^= "01100"b then do; /* trouble */ call err_proc (-1, 0, "Process lacks access to read and delete another user's requests. ^a", mseg_name); end_msg_seg = "1"b; go to next_msg; end; end; else if (mode & "00010"b) ^= "00010"b then do; /* otherwise process must have own access */ call err_proc (-1, 0, "Process lacks access to message segment. ^a", mseg_name); end_msg_seg = "1"b; go to next_msg; end; end_msg_seg = "0"b; /* not at end of message segment yet */ /* The first read from a message segment will be for the first message. The own entry is used */ /* to get the callers own messages. In admin mode, we read every message. */ re_read_label = first_read; /* come here if salvaged */ first_read: mseg_message_info.own = ^search_all_sw; mseg_message_info.message_code = MSEG_READ_FIRST; call message_segment_$read_message_index (mseg_idx (queue_no), areap, mseg_message_info_ptr, code); message_loop: if code ^= 0 then if try_again & code = error_table_$bad_segment then do; /* salvaged! Try again? */ call err_proc (1, 0, "Warning: message segment ^a has been salvaged.", mseg_name); try_again = "0"b; /* avoid looping forever */ go to re_read_label; end; else go to message_error; /* abort this mseg */ try_again = "1"b; /* got a good message, allow for second salvage */ bad_msg_version = "0"b; /* assume good format, then we check */ reqp = mseg_message_info.ms_ptr; if reqp -> queue_msg_hdr.hdr_version ^= queue_msg_hdr_version_1 then bad_msg_version = "1"b; rdir = reqp -> queue_msg_hdr.dirname; /* if bad version, these will not be used */ rseg = reqp -> queue_msg_hdr.ename; msg_id_code = reqp -> queue_msg_hdr.msg_time; if bad_msg_version then do; rseg = "Undefined_Segment_Name"; /* set this for messages */ if MATCH_ID ^= "" then go to next_msg; /* can't trust msg_id_code, so flush */ end; else do; /* for good messages, find directory uid */ call expand_pathname_ (rdir, req_dir_dir, req_dir_ent, code); call hcs_$status_long (req_dir_dir, req_dir_ent, 1, addr (br), null, code); if code ^= 0 then do; req_dir_uid = ""b; end; else do; req_dir_uid = br.uid; /* save for the uid match */ end; if MATCH_ID ^= "" then do; /* are we looking for one match id? */ if ^match_request_id_ (msg_id_code, MATCH_ID) then go to next_msg; /* if not this one, go on */ end; if sender_sw & sender ^= reqp -> request.sender then go to next_msg; /* check for RJE station sender if needed */ end; mseg_sender_id = mseg_message_info.sender_id; if search_all_sw then do; /* are we looking for a particular sender's request */ /* and if so is this his request */ if (person ^= "*") & (person ^= before (mseg_sender_id, ".")) then go to next_msg; if (project ^= "*") & (project ^= before (after (mseg_sender_id, "."), ".")) then go to next_msg; end; arg_didnt_match = "0"b; /* see if one request id didn't match this request */ arg_did_match = "0"b; /* and if one did. */ do arg_no = 1 to nargs; /* scan all request identifier arguments for a match */ if ^used_up (arg_no) then do; if bad_msg_version then /* can we delete it anyway? */ if type (arg_no) = ENTRY & starname (arg_no) = 2 then go to found_match; else if one_request_only then go to next_msg; else go to next_arg; call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if type (arg_no) = PATH | type (arg_no) = ENTRY then do; if type (arg_no) = PATH then do; /* get dir and entry name for argument */ call expand_pathname_ (arg, dir, input_seg, code); if rdir ^= dir then /* directories do not match */ if arg_dir_uid (arg_no) ^= ""b & req_dir_uid ^= ""b then do; /* try uid match */ if arg_dir_uid (arg_no) ^= req_dir_uid then go to no_match; /* dir mismatch? */ end; else go to no_match; /* no valid uids & no dir match */ end; else do; /* otherwise we just have an entry name */ input_seg = arg; dir = ""; end; if starname (arg_no) = 2 then go to found_match; /* try for speed */ call match_star_name_ (rseg, input_seg, code); /* see if entry names match */ if code ^= 0 then if queue_type = "absentee" then do; /* for absentee, check for .absin */ /* if suffix missing - append it */ call suffixed_name_$make (input_seg, "absin", input_seg, code); if code ^= 0 then do; call err_proc (-1, code, " Argument ^a ignored.", arg); used_up (arg_no) = "1"b; go to no_match; end; call match_star_name_ (rseg, input_seg, code); /* see if entry names match */ if code ^= 0 then go to no_match; end; else go to no_match; end; else do; /* only thing left is a match ID */ input_seg = ""; dir = ""; if ^match_request_id_ (msg_id_code, arg) then go to no_match; if arglen = 19 & ^one_request_only then starname (arg_no) = 2; /* all the digits, treat as starname */ if id_match_ms_id = ""b then /* record first request id match */ id_match_ms_id = mseg_message_info.ms_id; end; /* This request matches, record it for later or process if starname or full ID given. */ /* Ignore the fact that one request can match more than one request identifier */ /* (e.g., >dir>foo, -entry foo, -id ) */ found_match: matched (arg_no) = matched (arg_no) + 1; /* count number of matches */ queue (arg_no) = queue_no; /* record the queue */ msg_id (arg_no) = mseg_message_info.ms_id; /* and message id */ req_seg (arg_no) = rseg; /* save the segment name for messages */ if one_request_only then do; /* handle different, all args must match 1 request */ found_one_match = "1"b; /* some arg matched some request */ arg_did_match = "1"b; /* got an arg matching this request */ if id_match_ms_id ^= ""b then /* if some request id matched, it better be this one */ if id_match_ms_id ^= mseg_message_info.ms_id then go to no_match; if entry = ASN | entry = ASC then a_req_id_ret = reqp -> queue_msg_hdr.msg_time; go to next_arg; end; if starname (arg_no) > 0 then do; if entry = CDR | entry = COR | entry = CAR | entry = CRR then call delete_request (mseg_idx (queue_no), msg_id (arg_no), "1"b, code); else call move_request (mseg_idx (queue_no), msg_id (arg_no), code); if code ^= 0 then matched (arg_no) = matched (arg_no) - 1; /* request not found */ end; go to next_msg; end; do while ("0"b); /* skip next statement when falling through */ /* i.e., when the arg was already used up */ no_match: arg_didnt_match = "1"b; end; next_arg: end; if arg_did_match & ^arg_didnt_match then do; /* the one_request_only case */ if found_all_arg_match then do; /* more than one matched all_arg args */ bad_match: msg = "Specified arguments do not define a unique request."; if entry = ASN | entry = ASC then a_req_id_ret = 0; code = 0; go to abort_cmd; end; found_all_arg_match = "1"b; /* this is the request we want (we hope) */ single_ms_id = mseg_message_info.ms_id; end; next_msg: if reqp ^= null then do; /* free up allotment in area if necessary */ free reqp -> request; reqp = null; /* indicate that freeing performed */ end; if end_msg_seg then /* this queue is done */ if queue_no < last_q then do; /* do we want to look at other queues */ queue_no = queue_no + 1; /* look at next priority level */ go to queue_loop; end; else go to delete_things; /* now do the final deletions or moves */ old_ms_id = mseg_message_info.ms_id; /* want to continue reading more requests */ /* For each read after the first, read the next message in the queue */ re_read_label = inc_read; /* retries now come here */ inc_read: mseg_message_info.own = ^search_all_sw; mseg_message_info.message_code = MSEG_READ_AFTER_SPECIFIED; mseg_message_info.ms_id = old_ms_id; call message_segment_$read_message_index (mseg_idx (queue_no), areap, addr (mseg_message_info), code); go to message_loop; /* Now we are ready to delete/move things specified uniquely if there was only a single match */ delete_things: if one_request_only then do; /* double check this case */ code = 0; /* for error reporting */ if ^found_one_match then do; if target_queue = -10 then /* if not moving, simple message */ msg = "No matching request found."; else msg = "No matching request found outside of " || Q_name (target_queue); /* hide Q 0, but accurate */ go to abort_cmd; end; else if ^found_all_arg_match then go to bad_match; else do; /* delete/move the single request */ queue_no = -10; /* mark as undefined for now */ do idx = 1 to nargs while (queue_no = -10); if ^used_up (idx) then if msg_id (idx) = single_ms_id then do; /* this is it */ arg_no = idx; /* get ready for the internal procs */ queue_no = queue (arg_no); end; end; if queue_no = -10 then do; /* OOPS, Programming error */ msg = "Software error, try other arguments."; go to abort_cmd; end; if entry = ASC | entry = CAR | entry = CDR | entry = COR | entry = CRR then call delete_request (mseg_idx (queue_no), single_ms_id, "0"b, code); else call move_request (mseg_idx (queue_no), single_ms_id, code); if code ^= 0 then do; msg = "Request already gone from " || Q_name (queue_no); go to abort_cmd; end; end; go to DONE; /* omit the next bunch of loops */ end; do arg_no = 1 to nargs; /* last time around, delete or move single matches */ if ^used_up (arg_no) & starname (arg_no) = 0 then do; if matched (arg_no) > 1 then do; /* oops, multiple matches, complain */ call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if type (arg_no) = PATH then do; /* make up full path for error msg */ call absolute_pathname_ (arg, msg, code); /* it expanded before ok */ msg = "pathname " || substr (msg, 1, length (rtrim (msg))); /* mark the front with type */ end; else if type (arg_no) = ENTRY then msg = "entry " || arg; else msg = "match id " || arg; call ioa_$rsnnl ("Did not ^a requests: ^d matches found for ^a", long_msg, len, verb, matched (arg_no), msg); call err_proc (-1, 0, "^a", long_msg); used_up (arg_no) = "1"b; end; else if matched (arg_no) = 1 then do; /* could have been no match */ queue_no = queue (arg_no); /* queue we found it in */ if entry = CAR | entry = CDR | entry = COR | entry = CRR then call delete_request (mseg_idx (queue_no), msg_id (arg_no), "0"b, code); else call move_request (mseg_idx (queue_no), msg_id (arg_no), code); used_up (arg_no) = "1"b; end; end; end; if ^brief_sw then /* report any no-matches unless user said be quiet */ do arg_no = 1 to nargs; if matched (arg_no) = 0 & ^used_up (arg_no) then do; call cu_$arg_ptr_rel (arg_no, argptr, arglen, code, alp); if MATCH_ID ^= "" then id_msg = "ID " || rtrim (MATCH_ID) || " "; else id_msg = ""; if type (arg_no) = PATH then do; /* make up full path for error msg */ call absolute_pathname_ (arg, msg, code); /* it expanded before ok */ msg = id_msg || "pathname " || msg; /* mark the front with type */ end; else if type (arg_no) = ENTRY then msg = id_msg || "entry " || arg; else msg = "match id " || arg; call ioa_$rsnnl ("Request^[s^;^] not found in ^a ^[^a^;queues^s^]: ^a", long_msg, len, (starname (arg_no) > 0), queue_type, ^all_sw, Q_name (queue_no), msg); call err_proc (-1, 0, "^a", long_msg); end; end; /* INTERNAL PROCEDURES WHICH MUST BE WITHIN THE SCOPE OF THIS BEGIN BLOCK FOLLOW */ /* INTERNAL PROCEDURES - INSIDE BEGIN BLOCK */ move_request: proc (mseg_idx, msg_id, code); dcl mseg_idx fixed bin; dcl msg_id bit (72) aligned; dcl code fixed bin (35); dcl new_msg_id bit (72) aligned; dcl req_ptr ptr init (null); dcl msg_len fixed bin (24); dcl try_again bit (1); on cleanup begin; if req_ptr ^= null then free req_ptr -> request; end; try_again = "1"b; /* allow retry on read */ mseg_message_info.ms_ptr = null; /* no current allocation */ read_again: mseg_message_info.own = ^admin_sw; mseg_message_info.message_code = MSEG_READ_SPECIFIED; mseg_message_info.ms_id = msg_id; call message_segment_$read_message_index (mseg_idx, areap, addr (mseg_message_info), code); /* read the current message */ if code ^= 0 then do; forget_it: if mseg_message_info.ms_ptr ^= null then free mseg_message_info.ms_ptr -> request; if code = error_table_$no_message then return; if try_again & code = error_table_$bad_segment then do; /* salvaged */ try_again = "0"b; go to read_again; end; call err_proc (-1, code, "Message segment error.", ""); go to DONE; end; req_ptr = mseg_message_info.ms_ptr; /* so cleanup handler can function */ msg_len = mseg_message_info.ms_len; if req_ptr -> request.state = STATE_TRANSITION | req_ptr -> request.state = STATE_RUNNING then do; call ioa_$rsnnl ("Request ^a>^a ^a not moved.^/It is already running.", long_msg, len, req_ptr -> request.dirname, req_ptr -> request.ename, request_id_ (req_ptr -> request.msg_time)); call msg_proc (rtrim (long_msg)); return; end; req_ptr -> request.state = STATE_UNPROCESSED; /* reset state like a new request */ if admin_sw then do; on linkage_error begin; /* in case process faults on queue_admin_ gate */ call err_proc (-1, 0, "Process lacks access to move another user's requests.", ""); go to DONE; /* just give up */ end; call queue_admin_$add_index (target_mseg_idx, addr (mseg_message_info), new_msg_id, code); if code ^= 0 then go to forget_it; revert linkage_error; end; else do; call message_segment_$add_index (target_mseg_idx, req_ptr, msg_len, new_msg_id, code); if code ^= 0 then go to forget_it; end; free req_ptr -> request; req_ptr = null; if entry = MAR | entry = ASM | entry = ASN then /* just for absentee */ wakeup_answering_service = "1"b; /* tell AS to look over the queues */ /* if that went well we can delete the old message from the original queue */ call message_segment_$delete_index (mseg_idx, msg_id, code); if code ^= 0 then do; /* duplicate messages exist */ call err_proc (-1, code, "^/Message added to target queue, but not deleted from source. ^a", req_seg (arg_no)); go to DONE; end; if ^brief_sw & ((starname (arg_no) > 0) | all_sw) then do; /* print message for multi-match */ if entry = MAR | entry = ASM | entry = ASN then do; call ioa_$rsnnl ("Absentee request ^a^[ for ^a^;^s^] moved from ^a to ^a.", long_msg, len, req_seg (arg_no), admin_sw, sender_id, Q_name (queue_no), Q_name (target_queue)); call msg_proc (rtrim (long_msg)); end; else call ioa_ ("Daemon request ^a^[ for ^a^;^s^] moved from ^a queue ^d to^[ ^a^;^s^] queue ^d.", req_seg (arg_no), admin_sw, sender_id, queue_type, queue_no, to_rqt_sw, target_queue_type, target_queue); end; return; end move_request; delete_request: proc (mseg_idx, msg_id, force_sw, code); dcl mseg_idx fixed bin; dcl msg_id bit (72) aligned; dcl force_sw bit (1); dcl code fixed bin (35); dcl as_code fixed bin (35); dcl req_ptr ptr init (null); dcl msg_len fixed bin (24); dcl try_again bit (1); dcl answer char (12) var; dcl rq_state fixed bin; on cleanup begin; if req_ptr ^= null then free req_ptr -> request; end; as_code = 0; /* be sure this is cleared */ try_again = "1"b; /* allow retry on read */ mseg_message_info.ms_ptr = null; /* no current allocation */ if entry = CRR then go to re_try; /* do we check for a running job? */ read_again: mseg_message_info.own = ^admin_sw; mseg_message_info.message_code = MSEG_READ_SPECIFIED; mseg_message_info.ms_id = msg_id; call message_segment_$read_message_index (mseg_idx, areap, addr (mseg_message_info), code); /* read the current message */ if code ^= 0 then do; forget_it: if mseg_message_info.ms_ptr ^= null then free mseg_message_info.ms_ptr -> request; if code = error_table_$no_message then return; if try_again & code = error_table_$bad_segment then do; /* salvaged */ try_again = "0"b; go to read_again; end; call err_proc (-1, code, "Message segment error.", ""); go to DONE; end; req_ptr = mseg_message_info.ms_ptr; /* so cleanup handler can function */ msg_len = mseg_message_info.ms_len; rq_state = req_ptr -> request.state; if entry = CAR | entry = ASC then do; /* Absentee checks */ if rq_state = STATE_TRANSITION | rq_state = STATE_RUNNING then do; /* already going */ if entry = ASC then do; /* avoid questions and return code */ as_code = error_table_$request_pending; end; else do; if type (arg_no) = ID & force_sw then go to bump_it; /* fully defined, don't ask */ query_info.version = query_info_version_4; query_info.yes_or_no_sw = "1"b; query_info.suppress_name_sw = "0"b; answer = ""; /* clear the answer to be sure */ call command_query_ (addr (query_info), answer, id, "Request ^a>^a ^a is^[^xnow being considered for^] running.^/Do you wish to cancel and bump it^[^xif it is running^]?", req_ptr -> request.dirname, req_ptr -> request.ename, request_id_ (req_ptr -> request.msg_time), (rq_state = STATE_TRANSITION), (rq_state = STATE_TRANSITION)); if answer ^= "yes" then return; /* otherwise it is no or an error */ bump_it: call send_as_wakeup (ASR_AC_CANCEL, req_ptr -> request.msg_time); end; end; end; free req_ptr -> request; req_ptr = null; try_again = "1"b; /* IO_Daemons 79: Warn user that running daemon request can not be cancelled and leave the request in the queue */ re_try: if (entry = COR | entry = CDR ) & (rq_state = STATE_RUNNING) then call ioa_ ("Unable to cancel daemon request ^a^[ for ^a^;^s^] from ^a queue ^d. It is already running.", req_seg (arg_no), admin_sw, sender_id, queue_type, queue_no); else do; /* delete the message from the original queue */ call message_segment_$delete_index (mseg_idx, msg_id, code); if code ^= 0 then do; if code = error_table_$no_message then return; /* someone got it first */ if try_again & code = error_table_$bad_segment then do; try_again = "0"b; go to re_try; end; call ioa_$rsnnl ("^/Unable to cancel request ^a from ^a queue ^d.", long_msg, len, req_seg (arg_no), queue_type, queue_no); call err_proc (-1, code, "^a", long_msg); go to DONE; /* stop trying now */ end; if (rq_state = STATE_RUNNING) | ^brief_sw & ((starname (arg_no) > 0) | all_sw) then do; /* print message for multi-match */ if entry = CAR | entry = ASC then do; call ioa_$rsnnl ("Absentee request ^a^[ for ^a^;^s^] cancelled^[ from ^a^;^s^].", long_msg, len, req_seg (arg_no), admin_sw, sender_id, all_sw, Q_name (queue_no)); call msg_proc (rtrim (long_msg)); end; else if entry = CDR | entry = COR then call ioa_ ("Daemon request ^a^[ for ^a^;^s^] cancelled^[ from queue ^d^;^s^].", req_seg (arg_no), admin_sw, sender_id, all_sw, queue_no); else if entry = CRR then call ioa_ ("Retrieval request ^a^[ for ^a^;^s^] cancelled^[ from queue ^d^;^s^].", req_seg (arg_no), admin_sw, sender_id, all_sw, queue_no); end; end; if code = 0 then code = as_code; /* pass back if set */ end delete_request; err_proc: proc (severity, code, ctl_string, argument); dcl severity fixed bin; dcl code fixed bin (35); dcl ctl_string char (*); dcl argument char (*); if call_sys_log then call sys_log_$error_log (severity, code, id, ctl_string, argument); else call com_err_ (code, id, ctl_string, argument); return; msg_proc: entry (ctl_string); if call_sys_log then call sys_log_$error_log (-1, 0, "", ctl_string); /* simple message */ else call ioa_ (ctl_string); return; end err_proc; /* END OF INTERNAL PROCEDURES WITHIN THE SCOPE OF THE BEGIN BLOCK */ DONE: end BLOCK; /* of begin block */ call cleaner_up; /* free, close etc. */ return; /* ENTRY POINTS TO SET TEST DIRECTORIES FOR EACH REQUEST TYPE */ test_car: test_mar: entry (test_sys_dir); /* entry point for testing car and mar commands */ dcl test_sys_dir char (*); abs_sysdir = test_sys_dir; /* copy name of test system directory */ not_initialized = "1"b; /* force definition of default and max queues */ return; test_cdr: test_mdr: entry (test_sys_dir); /* must share entry because of iod_info_ */ iod_sysdir = test_sys_dir; call iod_info_$test (test_sys_dir); not_initialized = "1"b; /* force definition of default and max queues */ return; test_crr: entry (test_sys_dir); retriever_sysdir = test_sys_dir; not_initialized = "1"b; /* force definition of default and max queues */ return; /* INTERNAL PROCEDURES - OUTSIDE SCOPE OF BEGIN BLOCK */ cleaner_up: proc; dcl ec fixed bin (35); dcl i fixed bin; if reqp ^= null then do; free reqp -> request; reqp = null; end; do i = -1 to 4; if mseg_idx (i) ^= 0 then call message_segment_$close (mseg_idx (i), ec); end; if target_mseg_idx ^= 0 then call message_segment_$close (target_mseg_idx, ec); if wakeup_answering_service then call send_as_wakeup (ASR_AC_LOGIN, (0)); return; end cleaner_up; init: proc; call iod_info_$queue_data ("printer", io_default_q, io_max_q, code); if code ^= 0 then do; /* attempt default action */ io_max_q = 4; /* the max max_q */ io_default_q = 3; /* as in the past */ end; abs_max_q = 4; /* AS creates foreground queue and queues 0, 1, 2, 3, & 4 */ call system_info_$default_absentee_queue (abs_default_q); if abs_default_q = 0 then abs_default_q = 3; /* default default queue is 3 */ call hcs_$star_ (retriever_sysdir, "volume_retriever*.ms", 2, null, ret_max_q, null, null, code); if code ^= 0 then ret_max_q = 3; /* retriever never has more than three */ ret_default_q = min (ret_max_q, 3); not_initialized = "0"b; /* we have the values now */ return; end init; send_as_wakeup: procedure (P_function, P_request_id); dcl P_function fixed bin parm; dcl P_request_id fixed bin (71) parm; local_asraci.version = ASR_AC_INFO_VERSION_1; local_asraci.action_code = P_function; local_asraci.request_id = P_request_id; local_asraci.header.version = as_request_version_1; local_asraci.header.type = ASR_ABS_COMMAND; local_asraci.header.reply_channel = 0; call send_as_request_$no_block (addr (local_asraci), currentsize (local_asraci), ""b, code); return; end send_as_wakeup; end cancel_abs_request;  enter_abs_request.pl1 07/17/90 1528.3rew 07/17/90 1522.6 286695 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ enter_abs_request: ear: procedure options (separate_static, variable); /* A command which places in a ring-1 message segment data that is interpreted as a request for an absentee process. The user of the command must provide a minumum of one argument - the pathname of the absentee input segment. In addition, the following options are allowed: -restart (-rt) . to indicate that the absentee computation may be started over . from the beginning if interupted -output_file (-of) . . to change the pathname of the absentee output file . whose default is identical to the input segment except for a suffix of .absout -limit (-li) . to indicate a cpu limit in seconds -arguments (-ag) . to provide a string containing arguments to the input segment (ala exec_com) -brief (-bf) . to indicate that the command is not to type anything if all goes well -long_id . to indicate that the long form of the request ID is to be typed -queue (-q) . to indicate in which queue request is to be placed - default is 3 -time (-tm) . to provide a time before which this request will not be run -resource (-rsc) STRING . . resource (like tape drives) needed by job -sender STRING . RJE station name or ID of other sender -comment (-com) STRING . . instructions to operator or anything else user puts in it -notify (-nt) . send user message on deferral, login, and logout of job -defer_indefinitely, -dfi . . defer job indefinitely; run when operator says to. -proxy USER . enter request on behalf of USER -foreground, -fg . log in as foreground user (i.e., like primary interactive user) -secondary, -sec . ok to log in foreground job as secondary user -truncate, -tc truncate the .absout file when the job runs -authorization STR, -auth STR . . sets the authorization of the process to that specified . . by STR; STR is a character string composed of level and . . category names for the desired authorization, separated . . by commas. STR cannot contain any embedded blank or tab . . characters. (The short names for each level and category . . always contain no blanks or tabs, and can be used . . whenever the corresponding long names contain blanks or . . tabs.) STR must represent an authorization that is less . . than or equal to the maximum authorization of Person_id . . on the Project_id. If -authorization is omitted, your . . current login authorization is used. (See the . . Programmer's Reference Manual for more information about . . process authorizations.) -home_dir PATH, -hd PATH . . sets your home directory to the path specified if your . . project administrator allows it. -no_start_up, -ns. instructs the standard process overseer not to execute . . your start_up.ec segment if the project administrator . . allows it. -process_overseer PATH, -po PATH . . sets your process overseer to the procedure given by path . . if your project administrator allows it. If path ends in . . the characters ",direct", the specified procedure is . . called directly during process initialization rather than . . by the standard system-provided procedure. This means . . that the program used by path must perform the tasks that . . would have been performed by the standard procedure. The . . length of the -po character strings must be less than 64 . . characters. -ring N, -rg N . sets your initial ring to N if this ring number is . . greater than or equal to your registered minimum ring and . . less than your registered maximum ring. start_up . instructs the standard process overseer to execute your . . start_up.ec segment If any error occurs, a request for an absentee process will not be made. */ /****^ HISTORY COMMENTS: 1) change(86-03-01,Gilcrease), approve(86-03-27,MCR7370), audit(86-06-25,Lippard), install(86-06-30,MR12.0-1082): comment for hcom. coded by E. Stone 5/71 as submit_abs_request modified by E. Stone 10/06/71 modified to be ear by Dennis Capps Feb 18, 1972 modified by Dennis Capps Feb 18, 1973 Modified 6/1/76 by Steve Herbst to check absin and absout seg access Modified 01/25/77 by C. D. Tavares to check -limit against site-defined max limit, not just "20 minutes" Modified April 1978 by T. Casey to use version 4 absentee request structure and store new argument info in it, and to clean up and modernize the code. Modified November 1978 by T. Casey for MR7.0 absentee enhancements. Modified June 1979 by C. Hornig to not insist on checking access. Modified November 1979 by T. Casey to print 8 digits of request ID by default. Modified 22 September 1980 by G. Palter to use site_settable default absentee queue and not look at installation_parms or whotab. Modified July 1984 by C. Marker changed the call to cu_$arg_count to include a code variable so that we can return the right error message when there is an attempt to use this as an active function. 2) change(86-03-27,Gilcrease), approve(86-03-27,MCR7370), audit(86-06-25,Lippard), install(86-06-30,MR12.0-1082): Add -truncate,-tc, and -extend arguments for truncating absout files. SCP6297. 3) change(86-04-01,Gilcrease), approve(86-04-01,MCR7372), audit(86-06-25,Lippard), install(86-06-30,MR12.0-1082): Remove restriction that .absin must be first argument. Allow the absout file to be a msf. Add "argument" to compare for "-ag" and "-arguments". 4) change(86-04-01,Lippard), approve(85-12-30,MCR7326), audit(86-10-27,GDixon), install(86-10-28,MR12.0-1200): Modified 13 December 1985 (above date to satisfy picky hcom) by Jim Lippard to use send_as_request_ instead of hcs_$wakeup. 5) change(87-07-07,GDixon), approve(87-07-07,MCR7741), audit(87-07-07,Hartogs), install(87-08-04,MR12.1-1055): Include user_abs_attributes.incl.pl1 as part of splitting abs_message_format.incl.pl1. 6) change(87-11-10,Parisek), approve(88-02-11,MCR7849), audit(88-05-03,Lippard), install(88-07-13,MR12.2-1047): A. Added more standard login control arguments; -authorization, -home_dir, -no_start_up, -process_overseer, -ring and -start_up. SCP 6367. B. Implemented use of exec_com search paths for locating the absin. SCP 6331. C. Removed all references to request, & local_asraci structures, and added references to abs_request_info data to be passed to enter_abs_request_ subroutine which will define the request structure data and establish the message segment. SCP 6367. 7) change(88-04-29,Parisek), approve(88-04-29,MCR7878), audit(88-05-03,Lippard), install(88-07-13,MR12.2-1047): Move input pathname parsing to the enter_abs_request_ subroutine. The subroutine now checks if ec search paths will be used. 8) change(88-08-16,Parisek), approve(88-09-22,MCR7991), audit(88-09-26,Fawcett), install(88-09-30,MR12.2-1124): Inhibit printing of messages if -brief given. 9) change(90-06-06,Vu), approve(90-06-06,MCR8177), audit(90-06-20,Schroth), install(90-07-17,MR12.4-1020): Users with minimum authorization greater than system_low are unable to submit absentee requests unless they state the authorization level. END HISTORY COMMENTS */ dcl aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned); dcl com_err_ entry options (variable); dcl convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl cu_$arg_count ext entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$level_get entry (fixed bin); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl enter_abs_request_ entry (ptr, ptr, fixed bin (35)); dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl get_authorization_ entry returns (bit (72) aligned); dcl get_group_id_$tag_star entry returns (char (32)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl ioa_$ioa_switch entry options (variable); dcl parse_resource_desc_$check entry (char (*), ptr, ptr, ptr, char (*) varying, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl system_info_$abs_limits entry ((4) fixed bin (35), fixed bin (35), (0:7, 4) fixed bin (35)); dcl system_info_$default_absentee_queue entry (fixed bin); dcl user_info_$attributes entry (char (*) varying); dcl user_info_$authorization_range entry ((2) bit (72) aligned); dcl user_info_$ring_range entry ((2) fixed bin); dcl iox_$error_output ext pointer; dcl as_error_table_$illegal_hd_arg ext fixed bin (35); dcl as_error_table_$illegal_ip_arg ext fixed bin (35); dcl as_error_table_$ring_too_high ext fixed bin (35); dcl as_error_table_$ring_too_low ext fixed bin (35); dcl error_table_$ai_out_range ext fixed bin (35); dcl error_table_$badopt ext fixed bin (35); dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$not_abs_path ext fixed bin (35); dcl error_table_$pathlong ext fixed bin (35); dcl error_table_$root ext fixed bin (35); dcl (addr, after, before, index, length, max, null, rtrim, substr, unspec) builtin; dcl cleanup condition; dcl argp ptr; /* pointer to argument */ dcl id char (17) int static init ("enter_abs_request") options (constant); /* name of command - for error messages */ dcl my_attributes char (128) varying; /* user's attributes */ dcl rsc_msg char (100) varying; /* place for error message about resource description */ dcl abs_user char (32); /* group id of absentee user */ dcl rqid char (19); /* to hold the request id for printing */ dcl option char (32) aligned init (""); /* copy of argument if an option */ dcl proxy_name char (32); /* personid of proxy user */ dcl string char (8) aligned; /* used for error message */ /* name of system directory in which absentee */ /* message segment & who table are located */ dcl sysdir char (168) aligned internal static init (">system_control_1"); dcl arglen fixed bin; /* length of argument string */ dcl code fixed bin (35); /* error code */ dcl queue fixed bin; /* queue number */ dcl ms_count fixed bin; /* number of previous absentee requests */ dcl n_arg fixed bin; /* argument number */ dcl i fixed bin; /* temp */ dcl ring fixed bin; /* user's validation level */ dcl min_ring fixed bin; /* minimum user ring */ dcl max_ring fixed bin; /* maximum user ring */ dcl ringrng (2) fixed bin; /* authorized login ring range */ dcl 1 local_ari aligned like abs_return_info; dcl attr_sw bit (1) aligned; /* indicates whether an attribute dependent control arg was given */ dcl input_sw bit (1) aligned; /* indicates whether input seg has been given twice */ dcl output_sw bit (1) aligned; /* indicates whether output seg has been given twice */ dcl arg_sw bit (1) aligned; /* indicates whether argument string has been given twice */ dcl limit_sw bit (1) aligned; /* indicates whether cpu limit has been given twice */ dcl proxy_sw bit (1) aligned; /* indicates if proxy request given twice */ dcl brief_sw bit (1) aligned; /* indicates whether brief option is wanted */ dcl long_id_sw bit (1) aligned; /* indicates whether long ID is wanted */ dcl queue_sw bit (1) aligned; /* indicates whether queue specified */ dcl foreground_sw bit (1) aligned; /* indicates whether foreground queue specified */ dcl aok bit (1) aligned; /* ON if user has requested attribute */ dcl number_of_arguments fixed bin; dcl length_of_arguments fixed bin; dcl (resource_argno, sender_argno, comment_argno) fixed bin init (0); dcl arg char (arglen) based (argp); dcl authorization bit (72) aligned; dcl authrng (2) bit (72) aligned; dcl max_authorization bit (72) aligned; dcl min_authorization bit (72) aligned; dcl default_cpu_limits (4) fixed bin (35); dcl default_foreground_cpu_limit fixed bin (35); dcl max_cpu_limits (0:7, 4) fixed bin (35); dcl maxlim fixed bin (35); %page; %include abs_request_dcls; %page; abs_request_info_ptr = null; on cleanup call cleanup_proc; call user_info_$ring_range (ringrng); /* Get user's low and high ring limits */ min_ring = ringrng (1); max_ring = ringrng (2); call user_info_$authorization_range (authrng); /* Get user's low and high auth limits */ min_authorization = authrng (1); max_authorization = authrng (2); arqi_resource_length = 0; /* Initialize variable extents for structure data */ arqi_comment_length = 0; arqi_arg_count = 0; arqi_max_arg_length = 0; call get_temp_segment_ (id, abs_request_info_ptr, code); if code ^= 0 then do; call com_err_ (code, id, "temporary segment"); goto RETURN; end; unspec (abs_request_info) = "0"b; abs_request_info.version = ABSENTEE_REQUEST_INFO_VERSION_3; /* set version number of absentee request */ local_ari.version = ABSENTEE_RETURN_INFO_VERSION_3; /* set return version */ call system_info_$default_absentee_queue (queue); /* get default */ if queue = 0 then queue = 3; /* must use default default */ abs_request_info.queue = DEFAULT_QUEUE; /* queue's name */ /* The absentee request structure that this program builds ends with a number of character strings (and one array) of variable extents. Their extents are declared using the refer option, and the values of the extents are stored in fixed binary variables near the beginning of the structure. The code that fills in the structure must be careful not to store into any of the variable extent elements until the values of all the extents have been computed and stored in the structure (since the offset of each of these elements is, of course, a function of the lengths of all those that precede it). There are comments in those places where it becomes known that all the refer extents have been set, noting that it is now ok to store into the variable extent elements. */ /* initialize structure elements */ abs_request_info.output_segment_dirname = ""; abs_request_info.output_segment_entryname = ""; abs_request_info.input_segment_dirname = ""; abs_request_info.pad = 0; abs_request_info.proxy_personid = ""; abs_request_info.proxy_projectid = ""; abs_request_info.sender = ""; abs_request_info.initial_ring = -1; /* If this value doesn't change we'll use default */ abs_request_info.home_dir = ""; abs_request_info.init_proc = ""; abs_request_info.resource = ""; abs_request_info.comment = ""; abs_request_info.arguments (*) = ""; abs_request_info.requested_authorization = get_authorization_ (); input_sw, /* initialize several variables */ output_sw, arg_sw, limit_sw, brief_sw, long_id_sw, proxy_sw, foreground_sw, queue_sw, attr_sw = "0"b; call cu_$level_get (ring); abs_user = get_group_id_$tag_star (); /* Change Person.Project.* to Person.Project.m */ substr (abs_user, length (rtrim (abs_user)), 1) = "m"; call cu_$arg_count (number_of_arguments, code); if code ^= 0 then do; call com_err_ (code, id); goto RETURN; end; if number_of_arguments = 0 then code = error_table_$noarg; n_arg = 1; do while (n_arg ^> number_of_arguments); call cu_$arg_ptr (n_arg, argp, arglen, code); if code ^= 0 then go to arg_err; if index (arg, "-") ^= 1 then do; /* convert argument to directory name & entry name */ if ^input_sw then do; abs_request_info.input_segment_dirname = arg; input_sw = "1"b; /* Note absin segment is supplied */ end; end; /* Now go thru all the rest of the arguments (if there are any ) */ else do; option = arg; /* make a copy for efficiency + for */ string = "After"; /* nice error message if arg missing after option */ if option = "-rt" | option = "-restart" then abs_request_info.restartable = "1"b; /* turn on appropriate bit in absentee request if restartable */ else if option = "-nt" | option = "-notify" then abs_request_info.notify = "1"b; /* notify user when request has logged in */ else if option = "-dfi" | option = "-defer" | option = "-defer_indefinitely" then abs_request_info.user_deferred_indefinitely = "1"b; /* operator must start absentee process */ else if option = "-of" | option = "-output_file" then do; if output_sw then do; /* check whether option given before */ dup_arg: call com_err_ (0, id, "Option ^a duplicated.", arg); goto RETURN; end; output_sw = "1"b; /* indicate that output option given */ call get_next_arg; /* convert from relative to full pathname */ call expand_pathname_$add_suffix (arg, "absout", abs_request_info.output_segment_dirname, abs_request_info.output_segment_entryname, code); if code ^= 0 then do; arg_err: call com_err_ (code, id, "^a", arg); goto RETURN; end; if abs_request_info.output_segment_entryname = "" then do; call com_err_ (error_table_$root, id, "^a", arg); goto RETURN; end; end; else if option = "-proxy" then do; /* submit on behalf of another user */ if proxy_sw then goto dup_arg; proxy_sw = "1"b; call get_next_arg; proxy_name = arg; abs_user = arg || ".p"; /* Proxy users are Person.Project.p */ end; else if option = "-rsc" | option = "-resource" | option = "-resources" then do; if resource_argno ^= 0 then goto dup_arg; /* already given once */ call get_next_arg; call parse_resource_desc_$check /* see if resource description is ok */ (arg, null (), null (), null (), rsc_msg, code); if code ^= 0 then do; /* parse_ ... returned us a message */ call com_err_ (0, id, "-resource error: ^a", rsc_msg); goto RETURN; end; else if rsc_msg ^= "" then /* warning about obsolete resource description */ call ioa_ ("^a: ^a", id, rsc_msg); /* print it and continue */ abs_request_info.resource_length = arglen; /* remember how long it is */ resource_argno = n_arg; /* and where it is */ end; else if option = "-sender" then do; /* logic is identical to that for -resource, above */ /* user optional string */ if sender_argno ^= 0 then goto dup_arg; call get_next_arg; sender_argno = n_arg; end; else if option = "-com" | option = "-cm" | option = "-comment" then do; if comment_argno ^= 0 then goto dup_arg; call get_next_arg; abs_request_info.comment_length = arglen; comment_argno = n_arg; end; else if option = "-li" | option = "-limit" then do; if limit_sw then go to dup_arg; /* check whether option given before */ limit_sw = "1"b; /* indicate that limit option given */ call get_next_arg; /* convert argument from character string to fixed bin */ /* and set max cpu time in request */ abs_request_info.max_cpu_time = cv_dec_check_ (arg, code); if code ^= 0 then goto num_err; if abs_request_info.max_cpu_time < 0 then do; /* check number for reasonable value */ num_err: call com_err_ (0, id, "Invalid cpu limit ^a", arg); goto RETURN; end; end; else if option = "-ag" | option = "-argument" | option = "-arguments" then do; /* Everything after this is assumed to be arguments to the absentee job. */ abs_request_info.arg_count = number_of_arguments - n_arg; /* remember how many there are */ /* Make one pass to get the argument lengths that arguments are dependent on in their dcls, then make a second pass to fill in the arguments themselves. */ length_of_arguments = 1; do i = 1 to abs_request_info.arg_count; call get_next_arg; length_of_arguments = length_of_arguments + arglen; end; abs_request_info.max_arg_length = length_of_arguments - 1; length_of_arguments = 1; n_arg = n_arg - abs_request_info.arg_count; do i = 1 to abs_request_info.arg_count; call get_next_arg; abs_request_info.arguments (i) = substr (arg, 1, arglen); end; end; else if option = "-bf" | option = "-brief" then brief_sw = "1"b; /* indicate that brief option is in force */ else if option = "-lgid" | option = "-long_id" then long_id_sw = "1"b; /* long request identifier */ else if option = "-q" | option = "-queue" then do; if queue_sw then go to dup_arg; /* check whether option given before */ queue_sw = "1"b; /* indicate that queue specified */ call get_next_arg; begin; /* rowr-bazzle PL/1 */ dcl queue35 fixed bin (35); queue35 = cv_dec_check_ (arg, code); /* see if valid number */ queue = queue35; /* harrumph */ end; if code ^= 0 then do; if arg = "fg" | arg = "foreground" | arg = "-fg" | arg = "-foreground" then do; foreground_sw = "1"b; queue_sw = ""b; /* a numbered queue not really given */ queue = 0; /* 0 means "interactive" to some programs */ end; else do; bad_queue: call com_err_ (0, id, "Illegal queue number ^a", arg); goto RETURN; end; end; /* construct entry name of absentee message segment */ else do; if queue < 0 | queue > 4 then goto bad_queue; abs_request_info.queue = BACKGROUND_QUEUE (queue); if queue = 0 then queue = 1; /* queue zero is really the front end of queue 1 */ end; end; else if option = "-fg" | option = "-foreground" then do; /* login as primary user (like interactive for load_control info) */ foreground_sw = "1"b; queue = 0; end; else if option = "-tm" | option = "-time" then do; if abs_request_info.deferred_time > 0 then go to dup_arg; /* check whether option given before */ call get_next_arg; call convert_date_to_binary_ (arg, abs_request_info.deferred_time, code); if code ^= 0 then go to arg_err; end; else if option = "-sec" | option = "-secondary" | option = "-standby" then abs_request_info.secondary_ok = "1"b; /* not primary, but background user status */ else if option = "-truncate" | option = "-tc" then abs_request_info.truncate_absout = "1"b; else if option = "-extend" then abs_request_info.truncate_absout = "0"b; else if option = "-authorization" | option = "-auth" then do; call get_next_arg; if substr (arg, 1, 1) = "-" then do; code = error_table_$noarg; go to arg_err; /* missing operand */ end; call convert_authorization_$from_string (authorization, (arg), code); if code ^= 0 then goto arg_err; if aim_check_$in_range (authorization, authrng) then abs_request_info.requested_authorization = authorization; /* check if range is within limits found earlier */ else do; code = error_table_$ai_out_range; /* not in range */ goto arg_err; end; attr_sw = "1"b; /* used if submitted by proxy */ /* so warning message will be printed */ end; else if option = "-home_dir" | option = "-hd" then do; call get_attributes ("vhomedir", aok); /* does user have this attribute? */ if aok then do; /* yes */ call get_next_arg; if substr (arg, 1, 1) = "-" then do; /* not a control arg */ code = error_table_$noarg; goto arg_err; end; if substr (arg, 1, 1) ^= ">" then do; code = error_table_$not_abs_path; goto arg_err; end; if arglen > length (abs_request_info.home_dir) then do; code = error_table_$pathlong; goto arg_err; end; abs_request_info.home_dir = substr (arg, 1, arglen); end; else do; /* no */ code = as_error_table_$illegal_hd_arg; go to arg_err; end; attr_sw = "1"b; /* for proxy warning */ end; else if option = "-no_start_up" | option = "-ns" then do; abs_request_info.no_start_up = "1"b; /* do not execute start_up.ec during login */ attr_sw = "1"b; /* for proxy warning */ end; else if option = "-process_overseer" | option = "-po" then do; call get_next_arg; if substr (arg, 1, 1) = "-" then do; /* not a control arg */ code = error_table_$noarg; goto arg_err; end; if arglen > length (abs_request_info.init_proc) then do; code = error_table_$pathlong; goto arg_err; end; call get_attributes ("vinitproc", aok); /* does user have this attribute */ if aok then abs_request_info.init_proc = substr (arg, 1, arglen); /* yes */ else do; /* no */ code = as_error_table_$illegal_ip_arg; go to arg_err; end; attr_sw = "1"b; /* for proxy warning */ end; else if option = "-ring" | option = "-rg" then do; call get_next_arg; abs_request_info.initial_ring = cv_dec_check_ (arg, code); /* requesting ring */ if code ^= 0 then go to arg_err; if abs_request_info.initial_ring < min_ring then do; code = as_error_table_$ring_too_low; /* lower than lowest ring noted earlier */ goto arg_err; end; else if abs_request_info.initial_ring > max_ring then do; /* higher than highest ring noted earlier */ code = as_error_table_$ring_too_high; goto arg_err; end; attr_sw = "1"b; /* for proxy warning */ end; else if option = "-start_up" then do; /* inverse of -no_startup */ abs_request_info.no_start_up = "0"b; end; else do; code = error_table_$badopt; go to arg_err; end; end; n_arg = n_arg + 1; end; /* end loop over al2nd thru last arguments */ /* All done processing arguments. Now make some validity checks, and finish filling in the request structure. */ /* Check consistency of -queue, -foreground, and -secondary */ if queue_sw & foreground_sw then do; call com_err_ (0, id, "The -foreground and -queue arguments are inconsistent."); goto RETURN; end; if abs_request_info.secondary_ok & ^foreground_sw then do; call com_err_ (0, id, "The -secondary argument is only valid if the -foreground argument is also given."); goto RETURN; end; /* Either fill in default cpu time limit, or check specified limit for reasonableness. */ call system_info_$abs_limits (default_cpu_limits, default_foreground_cpu_limit, max_cpu_limits); /* get defaults */ if ^limit_sw then do; /* if -limit not given */ if foreground_sw then /* fill in the appropriate default limit */ abs_request_info.max_cpu_time = default_foreground_cpu_limit; else abs_request_info.max_cpu_time = default_cpu_limits (queue); end; if ^foreground_sw then do; /* if background job, check limit against per-shift max */ maxlim = 0; do i = 0 to 7; if maxlim < max_cpu_limits (i, queue) then maxlim = max_cpu_limits (i, queue); end; if abs_request_info.max_cpu_time > maxlim then do; call com_err_ (0, id, "Warning: the ^[specified^;default^] cpu time limit of ^d sec. is greater than the highest time limit for any shift (^d sec.). Request entered, but operator intervention will be required to log it in.", limit_sw, abs_request_info.max_cpu_time, maxlim); end; end; /* All of the refer extents have definitely been set by now, so we can store into the variable extent elements. */ if resource_argno ^= 0 then do; call cu_$arg_ptr (resource_argno, argp, arglen, code); abs_request_info.resource = arg; /* fill in requested resource */ end; if sender_argno ^= 0 then do; call cu_$arg_ptr (sender_argno, argp, arglen, code); abs_request_info.sender = arg; /* fill in requested sender string */ end; if comment_argno ^= 0 then do; call cu_$arg_ptr (comment_argno, argp, arglen, code); abs_request_info.comment = arg; /* fill in requested comment string */ end; /* set proxy name */ if proxy_sw then do; abs_request_info.proxy_personid = before (proxy_name, "."); abs_request_info.proxy_projectid = after (proxy_name, "."); if attr_sw then do; /* Print warning but continue to submit */ call ioa_$ioa_switch (iox_$error_output, "^a: Warning: Cannot check attribute information for user ^a. Job may not run successfully.", id, proxy_name); end; end; /* place request in message segment */ if foreground_sw then abs_request_info.queue = FOREGROUND_QUEUE; call enter_abs_request_ (abs_request_info_ptr, addr(local_ari), code); /* this subroutine actually queues the request */ if code ^= 0 then do; call com_err_ (code, id, local_ari.error_msg); goto RETURN; end; if ^brief_sw then do; ms_count = max (0, local_ari.queue_requests_count - 1); call ioa_$rsnnl ("^d", rqid, (0), local_ari.request_id); /* display successful request info */ if ^long_id_sw then rqid = substr (rqid, 7, 8); call ioa_ ("ID: ^a^[;^x^d already requested.^]", rqid, (code = 0), ms_count); call ioa_ ("^a in queue ^a", local_ari.abs_pathname, local_ari.queue); end; RETURN: call cleanup_proc; return; /* INTERNAL PROCEDURES */ cleanup_proc: proc; if abs_request_info_ptr ^= null then call release_temp_segment_ (id, abs_request_info_ptr, code); return; end cleanup_proc; /* -------------------- */ get_next_arg: proc; n_arg = n_arg + 1; call cu_$arg_ptr (n_arg, argp, arglen, code); if code ^= 0 then do; call com_err_ (code, id, "^a ^a", string, option); goto RETURN; end; return; end get_next_arg; /* -------------------- */ get_attributes: proc (pattr, paok); /* check various user attributes */ dcl pattr char (24) parameter; dcl paok bit (1) aligned parameter; call user_info_$attributes (my_attributes); if index (my_attributes, rtrim(pattr)) > 0 then paok = "1"b; /* have attribute */ else paok = "0"b; /* not have attribute */ end get_attributes; /* -------------------- */ test_ear: entry (test_sysdir); /* entry used for testing ear command */ dcl test_sysdir char (*); sysdir = test_sysdir; /* copy name of test system directory */ end enter_abs_request;  enter_abs_request_.pl1 01/17/89 1433.0rew 01/17/89 1342.2 214515 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /* format: style2,^inddcls,ifthenstmt,ifthendo,^indnoniterdo,^inditerdo,ind3,idind32 */ enter_abs_request_: procedure (p_abs_request_info_ptr, p_abs_return_info_ptr, p_code); /****^ HISTORY COMMENTS: 1) change(86-04-30,Cox), approve(86-05-01,MCR7390), audit(86-05-12,Newcomb), install(86-06-30,MR12.0-1082): Initially written. 2) change(86-06-23,Gilcrease), approve(86-06-23,MCR7370), audit(86-06-25,Lippard), install(86-06-30,MR12.0-1082): Change version number of abs_message_format, for -truncate .absout SCP6297. 3) change(86-06-23,Lippard), approve(85-12-30,MCR7326), audit(86-10-24,GDixon), install(86-10-28,MR12.0-1200): Modified 19 June 1986 (above date to satisfy picky hcom) by Jim Lippard to use absentee command AS request. 4) change(87-07-07,GDixon), approve(87-07-07,MCR7741), audit(87-07-07,Hartogs), install(87-08-04,MR12.1-1055): Include user_abs_attributes.incl.pl1 as part of splitting abs_message_format.incl.pl1. 5) change(87-11-11,Parisek), approve(88-02-11,MCR7849), audit(88-05-03,Lippard), install(88-07-13,MR12.2-1047): Added the referencing of the new abs_request_info version 3 elements. Use exec_com search paths for locating input absin. SCP 6367. 6) change(88-04-29,Parisek), approve(88-04-29,MCR7878), audit(88-05-03,Lippard), install(88-07-13,MR12.2-1047): Parse the input pathname here instead of the ear command module and check if ec search paths are required for locating absin. 7) change(88-08-15,Parisek), approve(88-09-22,MCR7977), audit(88-09-26,Fawcett), install(88-09-30,MR12.2-1124): Correct improper formatting of some error messages returned to the caller. Improve for coding standards. 8) change(88-11-22,Parisek), approve(89-01-03,MCR8032), audit(89-01-04,Farley), install(89-01-17,MR12.3-1005): Use fs_util_ entries for determining absin/absout segment types, and ACLs so ACLs for MSFs can be easily determined. END HISTORY COMMENTS */ /* Parameters */ dcl (p_abs_request_info_ptr, p_abs_return_info_ptr) ptr parameter; dcl p_code fixed bin (35) parameter; /* Automatic */ dcl aok bit (1) aligned; dcl arg_idx fixed bin; dcl authrng (2) bit (72) aligned; dcl ( code, default_cpu_limits dimension (4), default_foreground_cpu_limit ) fixed bin (35); dcl ignore_code fixed bin (35); dcl (input_entryname, login_name, message_seg_entry, output_entryname, proxy_name) char (32); dcl len_entry fixed bin; /* length of entry name of absentee control segment */ dcl len_path fixed bin; /* length of dir name of abs(in out) segs */ dcl 1 local_asraci aligned like asr_abs_command_info; dcl message_id bit (72) aligned; dcl must_search bit (1) aligned; dcl next_arg_position fixed bin; dcl (input_dirname, output_dirname, output_pathname) char (168); dcl rs_len fixed bin; dcl search_pname char (168); /* Directory name located through search paths */ dcl queue_picture picture "9"; dcl reqp ptr; dcl ringrng (2) fixed bin; /* Entries */ dcl aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_$tag_star entry () returns (char (32)); dcl cu_$level_get entry (fixed bin); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl fs_util_$get_type entry (char (*), char (*), char (*), fixed bin (35)); dcl fs_util_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl ioa_$rsnnl entry () options (variable); dcl message_segment_$add_file entry (char (*), char (*), ptr, fixed bin, bit (72) aligned, fixed bin (35)); dcl message_segment_$get_message_count_file entry (char (*), char (*), fixed bin, fixed bin (35)); dcl parse_resource_desc_$check entry (char (*), ptr, ptr, ptr, char (*) var, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl search_paths_$find_dir entry (char (*), ptr, char (*), char (*), char (*), fixed bin (35)); dcl send_as_request_$no_block entry (ptr, fixed bin, bit(72) aligned, fixed bin(35)); dcl suffixed_name_$make entry (char (*), char (*), char (32), fixed bin (35)); dcl suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35)); dcl system_info_$abs_limits entry ((4) fixed bin (35), fixed bin (35)); dcl system_info_$default_absentee_queue entry (fixed bin); dcl user_info_$attributes entry (char (*) varying); dcl user_info_$authorization_range entry ((2) bit (72) aligned); dcl user_info_$ring_range entry ((2) fixed bin); dcl user_info_$whoami entry (char (*), char (*), char (*)); /* External */ dcl ( as_error_table_$illegal_hd_arg, as_error_table_$illegal_ip_arg, as_error_table_$ring_too_high, as_error_table_$ring_too_low, error_table_$ai_out_range, error_table_$bad_subr_arg, error_table_$moderr, error_table_$noarg, error_table_$no_append, error_table_$no_search_list, error_table_$noentry, error_table_$not_seg_type, error_table_$no_s_permission, error_table_$null_info_ptr, error_table_$pathlong, error_table_$unimplemented_version ) fixed bin (35) external; /* Constant */ dcl ( ABSENTEE_DIRECTORY char (168) initial (">system_control_1"), ABSENTEE_QUEUE_PREFIX char (9) initial ("absentee_"), ABSIN_SEG bit (1) aligned initial ("0"b), ABSOUT_SEG bit (1) aligned initial ("1"b), FOREGROUND_ABSENTEE_QUEUE_NAME char (32) initial ("absentee_foreground.ms"), ME char (32) initial ("enter_absentee_request_"), MESSAGE_SEG_SUFFIX char (2) initial ("ms") ) internal static options (constant); /* Conditions */ dcl cleanup condition; /* Builtins */ dcl (addr, clock, convert, currentsize, index, length, null, rtrim, reverse, search, substr, unspec) builtin; /* Program */ p_code = 0; abs_request_info_ptr = p_abs_request_info_ptr; if abs_request_info_ptr = null then call ERROR_RETURN (error_table_$null_info_ptr); abs_return_info_ptr = p_abs_return_info_ptr; if abs_return_info_ptr = null then call ERROR_RETURN (error_table_$null_info_ptr); if abs_request_info.attributes.attributes_mbz ^= "0"b then call ERROR_RETURN (error_table_$bad_subr_arg); if abs_request_info.version ^= ABSENTEE_REQUEST_INFO_VERSION_3 then call ERROR_RETURN (error_table_$unimplemented_version); if abs_return_info.version ^= ABSENTEE_RETURN_INFO_VERSION_3 then call ERROR_RETURN (error_table_$unimplemented_version); reqp = null (); /* initialize values */ abs_return_info.request_id = 0; abs_return_info.error_msg = ""; abs_return_info.abs_pathname = ""; on cleanup call clean_up (); call get_temp_segment_ (ME, reqp, code); if code ^= 0 then call ERROR_RETURN (code); /**** request_header */ unspec (request.request_header) = ""b; request.request_header.msg_time = clock (); request.request_header.hdr_version = queue_msg_hdr_version_1; input_dirname, input_entryname = ""; must_search = "0"b; if abs_request_info.input_segment_dirname = "" then do; code = error_table_$noarg; call ioa_$rsnnl ("Pathname of input segment.", abs_return_info.error_msg, rs_len, ""); call ERROR_RETURN (code); end; len_path = search (reverse (abs_request_info.input_segment_dirname), "<>") - 1; if len_path < 0 then must_search = "1"b; /* arg is entryname only, must use search paths */ call expand_pathname_$add_suffix (abs_request_info.input_segment_dirname, "absin", input_dirname, input_entryname, code); if code ^= 0 then call ERROR_RETURN (code); if must_search then do; call search_paths_$find_dir ("exec_com", null (), input_entryname, "", search_pname, code); /* use the exec_com search list */ if code = 0 then input_dirname = search_pname; else if code ^= error_table_$no_search_list then do; /* entry not found using ec search list */ call ioa_$rsnnl ("^a.absin using ^a search list.", abs_return_info.error_msg, rs_len, abs_request_info.input_segment_dirname, "exec_com"); call ERROR_RETURN (code); end; end; len_entry = length (rtrim (input_entryname)); len_path = length (rtrim (input_dirname)); if len_path + len_entry > length (request.request_header.dirname) then do; /* Full path name is now too long to remember. */ code = error_table_$pathlong; call ioa_$rsnnl ("^a", abs_return_info.error_msg, rs_len, abs_request_info.input_segment_dirname); call ERROR_RETURN (code); end; call CHECK_SEG_ACCESS (input_dirname, input_entryname, ABSIN_SEG); abs_return_info.abs_pathname = rtrim(input_dirname) || ">" || input_entryname; request.request_header.dirname = input_dirname; request.request_header.ename = input_entryname; request.request_header.message_type = 0 /* absentee request */; request.request_header.bit_flags.notify = abs_request_info.attributes.notify; /**** version & abs_attributes */ request.request_version = abs_message_version_6; unspec (request.abs_attributes), unspec (request.abs_status_flags) = ""b; request.abs_attributes = abs_request_info.attributes, by name; /**** foreground & queue */ if abs_request_info.queue = FOREGROUND_QUEUE then do; request.request_header.orig_queue = 1; message_seg_entry = FOREGROUND_ABSENTEE_QUEUE_NAME; end; else do; if abs_request_info.queue = DEFAULT_QUEUE then call system_info_$default_absentee_queue (request.request_header.orig_queue); else if abs_request_info.queue = BACKGROUND_QUEUE (0) then request.request_header.orig_queue = 1; /* queue 0 is really the front of queue 1 */ else if abs_request_info.queue = BACKGROUND_QUEUE (1) | abs_request_info.queue = BACKGROUND_QUEUE (2) | abs_request_info.queue = BACKGROUND_QUEUE (3) | abs_request_info.queue = BACKGROUND_QUEUE (4) then request.request_header.orig_queue = convert (request.request_header.orig_queue, abs_request_info.queue); else if abs_request_info.queue ^= BACKGROUND_QUEUE (4) then call ERROR_RETURN (error_table_$bad_subr_arg); call suffixed_name_$make (ABSENTEE_QUEUE_PREFIX || convert (queue_picture, request.request_header.orig_queue), MESSAGE_SEG_SUFFIX, message_seg_entry, code); end; /**** name & len_name */ call user_info_$whoami (login_name, (""), ("")); request.len_name = length (rtrim (login_name)); request.name = substr (login_name, 1, request.len_name); /**** output_file & len_output */ if abs_request_info.output_segment_dirname ^= "" then output_dirname = abs_request_info.output_segment_dirname; else output_dirname = input_dirname; if abs_request_info.output_segment_entryname ^= "" then call suffixed_name_$make (abs_request_info.output_segment_entryname, "absout", output_entryname, code); else call suffixed_name_$new_suffix (input_entryname, "absin", "absout", output_entryname, code); if code ^= 0 then call ERROR_RETURN (code); call CHECK_SEG_ACCESS (output_dirname, output_entryname, ABSOUT_SEG); output_pathname = pathname_ (output_dirname, output_entryname); request.len_output = length (rtrim (output_pathname)); request.output_file = substr (output_pathname, 1, request.len_output); /**** proxy_name & len_proxy & abs_attributes.proxy */ if abs_request_info.proxy_personid ^= "" then do; call ioa_$rsnnl ("^a.^a", proxy_name, request.len_proxy, abs_request_info.proxy_personid, abs_request_info.proxy_projectid); request.abs_attributes.proxy = "1"b; request.proxy_name = substr (proxy_name, 1, request.len_proxy); end; else request.abs_attributes.proxy = "0"b; /**** deferred_time & max_cpu_time & requested_authorization & attributes */ request.deferred_time = abs_request_info.deferred_time; if abs_request_info.deferred_time ^= 0 then request.user_deferred_until_time = "1"b; if abs_request_info.max_cpu_time = 0 then do; call system_info_$abs_limits (default_cpu_limits, default_foreground_cpu_limit); if abs_request_info.queue = FOREGROUND_QUEUE then request.max_cpu_time = default_foreground_cpu_limit; else request.max_cpu_time = default_cpu_limits (request.request_header.orig_queue); end; else request.max_cpu_time = abs_request_info.max_cpu_time; call user_info_$authorization_range (authrng); /* get user's low and high auth levels */ if aim_check_$in_range (abs_request_info.requested_authorization, authrng) then request.requested_authorization = abs_request_info.requested_authorization; /* auth level ok */ else do; code = error_table_$ai_out_range; /* not ok */ call ERROR_RETURN (code); end; request.restartable = abs_request_info.restartable; request.user_deferred_indefinitely = abs_request_info.user_deferred_indefinitely; request.secondary_ok = abs_request_info.secondary_ok; request.truncate_absout = abs_request_info.truncate_absout; /**** resource & sender & comment & home_dir & init_proc & len_= */ request.len_resource = abs_request_info.resource_length; request.len_sender = length (rtrim (abs_request_info.sender)); request.len_comment = abs_request_info.comment_length; if length (rtrim( abs_request_info.home_dir)) > 0 then do; /* home dir was specified */ call get_attributes ("vhomedir", aok); /* check if user has this attribute */ if aok then request.len_homedir = length (rtrim (abs_request_info.home_dir)); /* has attribute */ else do; code = as_error_table_$illegal_hd_arg; /* does not have attribute */ call ERROR_RETURN (code); end; request.home_dir = substr (abs_request_info.home_dir, 1, request.len_homedir); /* fill in specified home dir */ end; if length (rtrim(abs_request_info.init_proc)) > 0 then do; /* initial process overseer specified */ call get_attributes ("vinitproc", aok); /* check if user has this attribute */ if aok then request.len_initproc = length (rtrim (abs_request_info.init_proc)); /* has attribute */ else do; code = as_error_table_$illegal_ip_arg; /* does not have attribute */ call ERROR_RETURN (code); end; request.init_proc = substr (abs_request_info.init_proc, 1, request.len_initproc); /* fill in specified initial procedure */ end; if request.len_resource > 0 then do; /* resources specified */ call parse_resource_desc_$check ((abs_request_info.resource), null (), null (), null (), "", code); if code ^= 0 then call ERROR_RETURN (code); request.resource = abs_request_info.resource; end; if request.len_sender > 0 then request.sender = substr (abs_request_info.sender, 1, request.len_sender); /* sender string specified */ if request.len_comment > 0 then request.comment = abs_request_info.comment; /* comment string specified */ request.len_vpad = 0; /**** args & arg_lengths & arg_count & len_args */ request.arg_count = abs_request_info.arg_count; if request.arg_count > 0 then do; /* fill in argument string information */ request.len_args, next_arg_position = 0; do arg_idx = 1 to abs_request_info.arg_count; next_arg_position = request.len_args + 1; request.len_args = request.len_args + length (abs_request_info.arguments (arg_idx)); request.arg_lengths (arg_idx) = length (abs_request_info.arguments (arg_idx)); substr (request.args, next_arg_position, length (abs_request_info.arguments (arg_idx))) = abs_request_info.arguments (arg_idx); end; end; /**** initial_ring & no_start_up */ if abs_request_info.initial_ring ^= -1 then do; /* user specified an initial ring */ call user_info_$ring_range (ringrng); /* check allowed low and high ring values */ if abs_request_info.initial_ring < ringrng (1) then do; code = as_error_table_$ring_too_low; /* specified lower than lowest allowed */ call ERROR_RETURN (code); end; else if abs_request_info.initial_ring > ringrng (2) then do; code = as_error_table_$ring_too_high; /* specified higher than highest allowed */ call ERROR_RETURN (code); end; end; request.initial_ring = abs_request_info.initial_ring; /* fill in initial ring value */ request.abs_attributes.no_start_up = abs_request_info.attributes.no_start_up; /* fill in no_startup parameter */ request.request_header.std_length = currentsize (request); /* note the size of the request structure */ /**** end of request setup; now put request in queue */ call message_segment_$add_file (ABSENTEE_DIRECTORY, message_seg_entry, reqp, request.request_header.std_length * 36, message_id, code); /* queue request into the appropriate message segment */ if code ^= 0 then call ERROR_RETURN (code); abs_return_info.request_id = request.msg_time; /* fill in the return info to send back to caller */ if abs_request_info.queue = DEFAULT_QUEUE then abs_return_info.queue = convert (queue_picture, request.request_header.orig_queue) || " "; else abs_return_info.queue = abs_request_info.queue; call message_segment_$get_message_count_file (ABSENTEE_DIRECTORY, message_seg_entry, abs_return_info.queue_requests_count, code); if code ^= 0 then call ERROR_RETURN (code); local_asraci.version = ASR_AC_INFO_VERSION_1; local_asraci.action_code = ASR_AC_LOGIN; local_asraci.request_id = request.msg_time; local_asraci.header.version = as_request_version_1; local_asraci.header.type = ASR_ABS_COMMAND; local_asraci.header.reply_channel = 0; call send_as_request_$no_block (addr (local_asraci), currentsize (local_asraci), ""b, code); if code ^= 0 then call ERROR_RETURN (code); call clean_up (); EAR_RETURN: return; %page; CHECK_SEG_ACCESS: proc (cs_dir, cs_en, cs_seg_type); /* Absin segment must exist and give r access to the absentee user. Absout must either exist and give him w, or not exist and parent must give him a. */ dcl cs_dir char (168) parameter; dcl cs_en char (32) parameter; dcl cs_seg_type bit (1) aligned parameter; dcl (cs_ring) fixed bin; dcl cs_code fixed bin (35); dcl cs_type char (32); dcl cs_mode bit (36) aligned; dcl x_mode bit (36) aligned; /* Get type and bitcount of segment (chase links). This verifies that it exists, too. */ call cu_$level_get (cs_ring); call fs_util_$get_type (cs_dir, cs_en, cs_type, cs_code); /* We are checking as a favor to the user. If we can't know, go away quietly. */ if cs_code ^= 0 then if cs_code ^= error_table_$no_s_permission then do; if cs_code = error_table_$noentry & cs_seg_type = ABSOUT_SEG then do; /* absout does not exist */ call fs_util_$get_user_access_modes (cs_dir, "", get_group_id_$tag_star (), cs_ring, cs_mode, x_mode, cs_code); /* need access to create absout */ if cs_code ^= 0 then do; call ioa_$rsnnl ("Warning: Cannot check access on directory containing entry. Job may not run successfully.", abs_return_info.error_msg, rs_len); call ERROR_RETURN (cs_code); end; if ^(cs_mode = A_ACCESS | cs_mode = SA_ACCESS | cs_mode = SMA_ACCESS) then call ERROR_RETURN (error_table_$no_append); end; /* abort if: - any error (except no_s_permission) on absin seg, - any error (except no_s_permission or noentry) on absout seg, - any error (except no_s_permission) on absout dir. */ else do; call ioa_$rsnnl ("^a", abs_return_info.error_msg, rs_len, pathname_ (cs_dir, cs_en)); call ERROR_RETURN (cs_code); end; end; else do; call ioa_$rsnnl ("^a^[>^]^a", abs_return_info.error_msg, rs_len, cs_dir, (cs_dir ^= ">"), cs_en); call ERROR_RETURN (cs_code); end; /**** must be a segment, link or MSF */ else do; if cs_type = FS_OBJECT_TYPE_SEGMENT | cs_type = FS_OBJECT_TYPE_MSF | cs_type = FS_OBJECT_TYPE_LINK then do; /* Status call on segment ok. Now check access to it. */ call fs_util_$get_user_access_modes (cs_dir, cs_en, get_group_id_$tag_star (), cs_ring, cs_mode, x_mode, cs_code); if cs_code ^= 0 then do; call ioa_$rsnnl ("Warning: Cannot check access on ^a. Job may not run successfully.", abs_return_info.error_msg, rs_len, pathname_ (cs_dir, cs_en)); call ERROR_RETURN (cs_code); end; if (cs_seg_type = ABSIN_SEG & ^(cs_mode = R_ACCESS | cs_mode = RE_ACCESS | cs_mode = RW_ACCESS | cs_mode = REW_ACCESS)) | (cs_seg_type = ABSOUT_SEG & ^(cs_mode = W_ACCESS | cs_mode = RW_ACCESS | cs_mode = REW_ACCESS)) then do; call ioa_$rsnnl ("^a", abs_return_info.error_msg, rs_len, pathname_ (cs_dir, cs_en)); call ERROR_RETURN (error_table_$moderr); end; end; else do; call ioa_$rsnnl ("^a", abs_return_info.error_msg, rs_len, pathname_ (cs_dir, cs_en)); call ERROR_RETURN (error_table_$not_seg_type); end; end; end CHECK_SEG_ACCESS; get_attributes: procedure (p_attr, p_aok); /* check various user attributes */ dcl p_attr char (24) parameter; dcl p_aok bit (1) aligned parameter; dcl my_attributes char (128) varying; call user_info_$attributes (my_attributes); if index (my_attributes, rtrim(p_attr)) > 0 then p_aok = "1"b; else p_aok = "0"b; end get_attributes; clean_up: procedure (); if reqp ^= null () then call release_temp_segment_ (ME, reqp, ignore_code); return; end clean_up; %skip (2); ERROR_RETURN: proc (er_code); declare er_code fixed bin (35); call clean_up (); p_code = er_code; goto EAR_RETURN; end ERROR_RETURN; %page; %include abs_message_format; %page; %include abs_request_dcls; %page; %include access_mode_values; %page; %include as_request_header; %page; %include asr_abs_command; %page; %include copy_flags; %page; %include status_structures; %page; %include queue_msg_hdr; %page; %include suffix_info; %page; %include user_abs_attributes; end enter_abs_request_;  lar_util_.pl1 10/06/92 0025.9r w 10/06/92 0021.2 672516 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,^ifthendo */ /* format: off */ lar_util_: procedure (a_info_ptr, a_code); /* This procedure is called by the queue-listing commands lar, ldr, and lrr (entry points in the same command procedure). It formats information about absentee, I/O daemon, and retrieval requests, and places its output in a printable segment. It leaves room for a totals line at the beginning, and then goes back and fills it in after it has scanned all the pertinent requests and knows what the totals are. It operates on only one queue message segment at a time. If the user specified that all queues (of a certain kind) be listed, the command procedure calls this one once for each queue. The offset in the printable segment at which to start placing output is specified in the argument structure. All input and output arguments (except the error code) are passed in an argument structure, lar_info, a pointer to which is the first argument in the call. The structure is defined in lar_info.incl.pl1, and comments in that include file describe the meaning of each variable in the structure. There is one implicit convention observed between this procedure and its caller: this procedure avoids outputting totals lines that contain only zeros, when the -all argument was given, and it avoids outputting totals lines for queues from which no requests are selected, when the -search_all argument is given (or is in effect by default). The calling procedure, realizing this, must check whether anything is in the output segment, and, if not, print a message saying "No requests in any queue", or "No requests selected from any queue". */ /****^ HISTORY COMMENTS: 1) change(86-03-01,Gilcrease), approve(86-03-27,MCR7370), audit(86-07-07,Fawcett), install(86-06-30,MR12.0-1082): Dummy comment for hcom. Modified by E. Stone 10/06/71 Modified by Dennis Capps 3/20/72 Modified by Robert Coren 4/17/73 to handle io_daemon requests Modified by J. Stern 4/4/75 to print access classes in long mode Modified by D. Vinograd 5/77 to return info about retrieval queues Modified by J.Whitmore and T. Casey, April 1978, for new daemon and absentee queue entry formats Modified by T. Casey, November 1978, for MR7.0, to list absentee queues zero and foreground, and other absentee changes. Modified by T. Casey, April 1979, for MR7.0a, to identify deferred absentee requests that have not yet been processed. Modified by R. Brinegar, Summer 1979 to fix output format problems. Modified by S. Herbst, Fall 1979 to print request type in header. Modified by T. Casey, November 1979 to print 8 digits of request ID and to identify bumped absentee jobs properly. Modified by J. C. Whitmore, April 1980 for new retrieval request format using queue_msg_hdr Modified by G. Palter, 8 September 1981 to print the I/O daemon forms if given Modified by G. C. Dixon, Jan 1982 to support lor command. Modified by R. Kovalcik, June 1982 to understand dprint -dupt. Modified by C. Marker, November 1983 to add support for -no_separator Modified by JAFalksen, August 1984 to use new time facilities Modified by C. Marker, February 23, 1985 to use version 5 message segments 2) change(86-03-27,Gilcrease), approve(86-03-27,MCR7370), audit(86-07-07,Fawcett), install(86-06-30,MR12.0-1082): Add handling of truncate absout & restarted bits. SCP 6297. 3) change(87-07-07,GDixon), approve(87-07-07,MCR7741), audit(87-07-07,Hartogs), install(87-08-04,MR12.1-1055): Include user_abs_attributes.incl.pl1 as part of splitting abs_message_format.incl.pl1. 4) change(87-08-06,Gilcrease), approve(87-08-06,MCR7686), audit(88-02-01,Farley), install(88-02-02,MR12.2-1019): Add -nb message to lor/ldr -long. 5) change(87-11-11,Parisek), approve(88-02-11,MCR7849), audit(88-03-07,Lippard), install(88-07-13,MR12.2-1047): Reference version 6 abs_message_format structure, and if version 6 format output for the structure's new data. 6) change(87-11-13,Parisek), approve(88-02-11,MCR7849), audit(88-03-07,Lippard), install(88-07-13,MR12.2-1047): Display the request version 6 elements; no_start_up, home_dir, init_proc. SCP 6367. 7) change(88-04-20,Parisek), approve(88-06-13,MCR7913), audit(88-08-16,Farley), install(88-08-22,MR12.2-1089): Added the request_info entrypoint which called by the request_info command/active_function to return specific queue information about absentee, output, io, retrieval, and file transfer requests. Added the internal procedures, buffer_abs_element, buffer_com_element, buffer_out_element, buffer_retv_element, and buffer_imft_element to format the return information for the caller. Alter the flow of code execution at various points when the rqi_sw switch is ON. The rqi_sw informs lar_util_ that it was called by the request_info command/AF. Added checks for selecting OUTPUT requests with special forms only. 8) change(88-09-01,Parisek), approve(88-09-01,PBF7913), audit(88-09-07,Farley), install(88-09-09,MR12.2-1101): Removed the displaying of the "delete" and "dupt" request flags for request types they do not pertain to. Also check imft's "remote_transfer" flag before displaying the "files" and "subtrees" flags for the imft request type. "files" and "subtrees" do not pertain to imft requests coming from the remote system. 9) change(88-09-13,Beattie), approve(88-08-01,MCR7948), audit(88-10-11,Farley), install(88-10-14,MR12.2-1165): Add support for displaying extend, update and delete for IMFT requests. 10) change(88-09-13,Farley), approve(88-09-16,MCR7911), audit(88-10-25,Wallman), install(88-10-28,MR12.2-1199): Updated to use version 5 dprint_msg. Also added "plotter" as one of the valid output_modules. 11) change(90-12-10,Vu), approve(90-12-10,MCR8231), audit(92-09-25,Zimmerman), install(92-10-06,MR12.5-1021): Header for list_absentee_request has garbage total. END HISTORY COMMENTS */ /* format: on */ /* Arguments */ dcl a_info_ptr ptr; dcl a_code fixed bin (35); /* Automatic variables, in alphabetic order */ dcl abs_name char (32); dcl access_class bit (72) aligned; dcl aclass_string char (170); dcl af_flag_str char (512) varying; dcl afsw bit (1) aligned; /* active function call */ dcl agdd char (168); /* argument directory, directory portion */ dcl agde char (32); /* argument directory, entry portion */ dcl aguid bit (36); /* argument directory, UID */ dcl allsw bit (1) aligned; /* print all for request_info */ dcl areap ptr; dcl argl fixed bin; dcl argx fixed bin; /* argument string index */ dcl auto_forms_name char (forms_max_lth) varying; dcl buffer char (512) aligned; dcl check_abs_name bit (1) aligned; dcl check_user bit (1) aligned; dcl code fixed bin (35); dcl curarg_start fixed bin; dcl deferred_abs bit (1) aligned; dcl deferred_count fixed bin; dcl dirname char (168); dcl ename char (32); dcl expandedlen fixed bin; dcl expandlen fixed bin; dcl expandp ptr; dcl header_position fixed bin; dcl i fixed bin; dcl j fixed bin; dcl last_comma fixed bin; dcl len fixed bin; dcl len_offset fixed bin; dcl ll fixed bin; dcl 1 local_mseg_message_info like mseg_message_info aligned; dcl long_id bit (1) aligned; dcl messcount fixed bin; dcl modes char (100) var; dcl msg_time fixed bin (71); dcl n_bad_vrsn fixed bin; dcl no_totals bit (1) aligned; dcl offs char (256) varying; dcl offslen fixed bin (21); dcl old_ms_id bit (72) aligned; dcl ons char (256) varying; dcl onslen fixed bin (21); dcl pass1 bit (1) aligned; dcl person char (32); dcl position fixed bin; dcl print_requests bit (1) aligned; dcl print_user_column bit (1) aligned; dcl project char (32); dcl psn_ll fixed bin; dcl psn_s fixed bin; dcl queue_string char (32); dcl read_all bit (1) aligned; dcl reqp ptr; dcl retrying bit (1) aligned; dcl rqdd char (168); /* request directory, directory portion */ dcl rqde char (32); /* request directory, entry portion */ dcl rqid char (19); /* request directory, UID */ dcl rqi_buffered bit (1) aligned; /* ON if output buffered for rqi */ dcl rqi_sw bit (1) aligned; /* command/active function entry point */ dcl rs_len fixed bin; dcl s char (1) aligned; dcl scrunchedp ptr; dcl select_sw bit (1) aligned; dcl sender_id char (32); dcl state fixed bin; dcl str char (32) varying; dcl tbf char (32) var; dcl time char (64) var; dcl time_now fixed bin (71); dcl total_for_user fixed bin; dcl total_selected fixed bin; dcl user_matches bit (1) aligned; /* Based */ dcl region area (1000) based (areap); dcl cstrng char (info.output_count) aligned based (info.temptr); dcl args_con_blanks char (expandlen) aligned based (expandp); dcl args_sans_blanks char (expandlen) aligned based (scrunchedp); dcl based_dummy fixed bin based; /* for freeing requests without computing their extents */ /* Conditions */ dcl cleanup condition; /* Internal Static */ dcl header_length int static options (constant) fixed bin init (74); dcl ABS_VER_5 fixed bin (17) init (5) static options (constant); dcl ABS_VER_4 fixed bin (17) init (4) static options (constant); /* a request_version of 4 means that this abs was queued under MR11. */ /* Any abs queued under MR12 will be version 5. */ dcl DEFAULT_LINE_LTH int static options (constant) fixed bin init (79); dcl DEFAULT_OUTPUT_LTH int static options (constant) fixed bin init (-1); dcl IMFT fixed bin (17) int static options (constant) init (5); dcl TAB_39 int static options (constant) fixed bin init (39); dcl TAB_44 int static options (constant) fixed bin init (44); dcl TOO_SMALL_LINE_LTH int static options (constant) fixed bin init (50); dcl Notify_msg char (13) static options (constant) init ("Notify: yes "); dcl Restarted_msg char (16) int static options (constant) init ("Restarted: yes "); dcl Truncate_msg char (15) int static options (constant) init ("Truncate: yes "); dcl line_nbrs_msg char (18) static options (constant) init ("Line numbers: yes "); dcl DUPT_msg char (11) static options (constant) init ("DUPT: yes "); dcl NL char (1) int static options (constant) init (" "); dcl pp_request_type (2:4) char (9) aligned int static options (constant) init ("7punch", "mcc_punch", "raw_punch"); dcl state_names (-1:6) char (48) int static options (constant) init ("state undefined", /* -1 */ "unprocessed", /* 0 */ "deferred", /* 1 */ "state changing", /* 2 */ "eligible", /* 3 */ "running", /* 4 */ "bumped", /* 5 */ "deferred until process termination"); /* 6 */ dcl static_psn_s fixed bin int static; dcl static_ll fixed bin int static; dcl static_header_position fixed bin int static; dcl static_total_selected fixed bin int static; dcl static_messcount fixed bin int static; dcl static_deferred_count fixed bin int static; dcl static_position fixed bin int static; /* Ext Entries */ dcl aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl convert_authorization_$to_string_short ext entry (bit (72) aligned, char (*), fixed bin (35)); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry returns (char (32)); dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl ioa_$rs entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl get_line_length_ entry (char (*), fixed bin, fixed bin (35)); dcl get_system_free_area_ entry (ptr); dcl match_request_id_ entry (fixed bin (71), char (*)) returns (bit (1) aligned); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl message_segment_$get_message_count_index entry (fixed bin, fixed bin, fixed bin (35)); dcl message_segment_$read_message_index entry (fixed bin, pointer, pointer, fixed bin (35)); dcl request_id_ entry (fixed bin (71)) returns (char (19)); /* Builtins */ dcl (addr, after, before, clock, hbound, length, index, lbound, null, reverse, rtrim, substr, unspec) builtin; /* Error table */ dcl error_table_$moderr ext fixed bin; dcl error_table_$no_message ext fixed bin; dcl error_table_$bad_segment ext fixed bin (35); afsw = "0"b; rqi_sw = "0"b; goto COMMON_INIT; request_info: entry (a_info_ptr, a_afsw, a_code); dcl a_afsw bit (1) aligned; /* On if rqi called as AF */ /* This entry is called by the queue-info command/active function request_info. It produces output in a simple formatted line by line format. It does not produce any header or totals information in its output. */ afsw = a_afsw; rqi_sw = "1"b; COMMON_INIT: /* Initialize */ info_ptr = a_info_ptr; a_code = 0; reqp = null; total_selected, total_for_user, deferred_count, n_bad_vrsn, position, code = 0; time_now = clock (); /* Set some local switches, based on combinations of input switches */ if info.long_id_sw | info.long_sw then /* if -long or -long_id */ long_id = "1"b; /* print the long form of request IDs */ else long_id = ""b; /* else print the short form */ check_user = info.user_sw; /* see if a user name was specified by the caller */ if info.person = "*" & info.project = "*" then /* if caller said -user *.* */ check_user = ""b; /* pretend user was not specified */ if info.abs_q_1 & info.queue = 0 then /* if running Qs 0 and 1 together and this is Q 0 */ static_header_position = 0; /* indicate that we have no Q 0 output yet */ /* Decide whether to print the user column */ if info.admin_sw /* if we are in admin mode */ & (^check_user /* and we don't have a user name */ | (check_user /* or we have a user name */ & (info.person = "*" | info.project = "*"))) then /* but it could match several users */ print_user_column = "1"b; /* then print the user name for each request */ else print_user_column = ""b; /* else they're all from the same user so don't print the name */ /* See if we have to read all requests, or just those for the user whose process we're running in */ if info.admin_sw | info.position_sw then read_all = "1"b; else read_all = ""b; /* See if we have to look at the contents of a request to decide whether to select it */ if info.user_sw | info.immediate | info.resource_sw | info.dirname_sw | info.ename_sw | info.id_sw | info.deferred_indefinitely | info.sender_sw | info.forms_sw then select_sw = "1"b; /* we do */ else select_sw = ""b; /* we don't */ /* Initialize some variables used for checking the user ID of each request */ if check_user then do; /* if we have to check the user, copy the name and project */ person = info.person; project = info.project; end; /* but if user not specified */ else if info.position_sw /* and we can't use the "own" primitives because we have to read every request to get the positions of the ones we select */ & ^info.admin_sw then do; /* and we're not listing all users' requests */ person = get_group_id_ (); /* get the ID of this user so we can pick out his requests */ project = before (after (person, "."), "."); person = before (person, "."); check_user = "1"b; /* and remember to check each request for a matching user name */ end; /* If directory name supplied, get its UID, so we can try UID matching to get around the multiply-named directory problem */ if info.dirname_sw then do; call expand_pathname_ ((info.dirname), agdd, agde, code); if code ^= 0 then goto return_code; /* can't happen since caller already expanded it ok */ call hcs_$status_long (agdd, agde, (1), addr (branch_status), null, code); if code = 0 then aguid = branch_status.unique_id; else aguid = ""b; /* ""b means don't try UID matching */ end; /* If listing absentee requests, see if we have to append the .absin suffix to a name given by the user */ check_abs_name = ""b; if info.request_type = ABS then if index (info.ename, ".absin") = 0 & length (rtrim (info.ename)) <= 26 then do; abs_name = rtrim (info.ename) || ".absin"; check_abs_name = "1"b; end; /* Figure out where in the output segment to start putting our output lines . This gets complicated because we list absentee queues 0 and 1 as if they were one queue. Queue zero exists only so the operator can move requests "to the head of queue 1", even though it is impossible to add messages to the head of a message segment. So here, we have to adjust some variables to run the Q 0 and Q 1 listings together, instead of separating them by a header. */ info.output_count = info.input_count + 1; /* point output_count at first vacant char */ if rqi_sw then goto message_count; if info.output_count = 1 then /* if nothing in segment yet */ call put_message (NL); /* skip a line */ if (info.abs_q_1 & static_header_position > 0 & info.queue = 1) then do; /* if running Qs 0 and 1 together */ header_position = static_header_position; /* get position of header that's already there */ position = static_position; /* and Q position of last request in Q 0 */ deferred_count = static_deferred_count; /* and count of deferred requests */ if substr (cstrng, info.output_count - 2, 2) = NL || NL then /* if output seg ends in double newline */ info.output_count = info.output_count - 1; /* get rid of one of them */ if info.total_sw & info.position_sw & static_total_selected > 0 then do; /* continue position list from Q 0 */ psn_s = static_psn_s; /* position of the "s" in "Positions" */ ll = static_ll; /* terminal's line length */ psn_ll = 0; /* too difficult to append to current line, so start a new one */ if substr (cstrng, info.output_count - 2, 1) = "." then /* but if we can find the trailing period */ substr (cstrng, info.output_count - 2, 1) = ","; /* change it back to a comma */ substr (cstrng, psn_s, 2) = "s:"; /* and be sure it says "Positions:" */ end; /* end continue position list */ end; else do; /* else reserve a place for the header */ header_position = info.output_count; /* remember where it starts */ info.output_count = info.output_count + header_length; /* move vacant char index past space for header */ substr (cstrng, header_position, header_length) = ""; /* clear it, so we don't print lots of \000's if we exit with an error before getting around to filling it in */ static_total_selected = 0; /* and make sure there's no garbage in this variable */ end; /* See if we can get the total number of requests in the queue */ message_count: no_totals = ""b; /* assume we can */ call message_segment_$get_message_count_index (info.mseg_idx, messcount, code); if code ^= 0 then do; /* user might have read or own permission, but not status */ messcount = 0; if code ^= error_table_$moderr then goto return_code; /* if that is not the case, give up immediately */ else do; /* that was the case */ code = 0; no_totals = "1"b; /* remember not to print the total requests */ info.no_total_sw = "1"b; /* tell caller not to print "No requests in any queue" */ end; end; else if messcount = 0 then go to fin; /* if no requests then we are done */ if info.admin_sw /* if reading all requests */ & info.total_sw /* just to count them */ & ^select_sw /* and not being selective about it */ & ^info.position_sw /* and not printing their positions */ & ^no_totals /* and we were able to get the count */ then do; /* save lots of time */ total_for_user = messcount; total_selected = messcount; /* don't bother reading thru the queue */ goto fin; /* just go print the total */ end; /* Set up to read requests from the queue */ call get_system_free_area_ (areap); /* get area in which to place request */ mseg_message_info_ptr = addr (local_mseg_message_info); reqp, expandp, scrunchedp = null (); /* init for cleanup handler */ on cleanup call cleaner_up; /* establish cleanup handler */ /* Get started through the queue by reading either the first message in the queue, or the first message for this user */ retrying = ""b; retry_1: reqp, requestp, dmp = null; /* init these to avoid faults */ unspec (local_mseg_message_info) = ""b; local_mseg_message_info.version = MSEG_MESSAGE_INFO_V1; local_mseg_message_info.own = ^read_all; local_mseg_message_info.message_code = MSEG_READ_FIRST; call message_segment_$read_message_index (info.mseg_idx, areap, mseg_message_info_ptr, code); if ^retrying then /* retry the read once, if queue has been salvaged */ if code = error_table_$bad_segment then do; retrying = "1"b; goto retry_1; end; /* Top of loop through all requests in queue. The bottom of this loop, at the label "skip", does an incremental read and then comes here. We exit the loop by going to mess_err if code is nonzero. This is for both normal and abnormal exits. */ loop: if code ^= 0 then go to mess_err; /* exit loop if no message or real error */ reqp, requestp, dmp, ft_request_ptr = mseg_message_info.ms_ptr; /* set ptrs to all of the request structures */ sender_id = mseg_message_info.sender_id; access_class = mseg_message_info.ms_access_class; /* Check version of request, and complain if not current. It is worthwhile to diagnose this error, since it is likely to occur often now. We are changing the request versions, and there are lots of private versions of the ear and dprint commands around to put old version requests into the queues. */ if request.hdr_version ^= queue_msg_hdr_version_1 then goto vrsn_ng; if info.request_type = RETV then if retv_request.version = retv_request_version_2 then goto vrsn_ok; else goto vrsn_ng; else if info.request_type = ABS then if (request.request_version = abs_message_version_6 | request.request_version = ABS_VER_5 | request.request_version = ABS_VER_4) /* Allow old versions */ then goto vrsn_ok; else goto vrsn_ng; else if info.request_type = IO | info.request_type = OUTPUT then if dprint_msg.version = dprint_msg_version_5 | dprint_msg.version = dprint_msg_version_4 | dprint_msg.version = dprint_msg_version_3 then goto vrsn_ok; else goto vrsn_ng; else if (rqi_sw & info.request_type = IMFT) /* We only deal with IMFT in this module if invoked as request_info */ then if ft_request.version = FT_REQUEST_VERSION_1 then goto vrsn_ok; vrsn_ng: if rqi_sw & afsw then goto skip; /* simply ignore */ n_bad_vrsn = n_bad_vrsn + 1; /* count bad ones for printing in totals at end */ if check_user then do; /* don't complain to one user about another's bad requests */ if person ^= "*" then if person ^= before (sender_id, ".") then goto skip; if project ^= "*" then if project ^= before (after (sender_id, "."), ".") then goto skip; end; total_selected = total_selected + 1; /* we have "selected" this one, to complain about it */ total_for_user = total_for_user + 1; /* also count it among this user's requests */ if ^info.total_sw then do; /* long or normal mode; print stuff in mseg return args */ unspec (msg_time) = mseg_message_info.ms_id; /* this tells us when it was entered */ time = date_time_$format ("date_time", msg_time, "", ""); /* format it so we can show it to the user */ if info.long_sw then do; /* might as well make it look pretty */ call put_message (NL); call ioa_$rs ("User:^21t^a", buffer, len, sender_id); call put_buffer; call ioa_$rs ("Time queued:^21t^a", buffer, len, time); call put_buffer; call put_message_nl ("Request has obsolete or incorrect format"); end; else do; /* normal format */ if print_user_column then do; call ioa_$rsnnl ("^30a", buffer, len, sender_id); call put_buffer; end; call ioa_$rs ("Request has obsolete or incorrect format. Time queued: ^a", buffer, len, time); call put_buffer; end; end; /* end not totals */ goto skip; vrsn_ok: /* See if the user matches */ user_matches = ""b; /* start out being pessimistic */ if check_user then do; /* if user name was given, see if it matches */ if person ^= "*" then do; /* require matching person ID */ if person ^= before (sender_id, ".") then do; /* user does not match */ if info.request_type ^= ABS then goto wrong_user; if ^request.proxy then goto wrong_user; /* wrong_user unless proxy request */ if person ^= before (request.proxy_name, ".") then goto wrong_user; /* proxy user doesn't match */ end; end; if project ^= "*" then do; /* require matching project ID */ if project ^= before (after (sender_id, "."), ".") then do; /* project does not match */ if info.request_type ^= ABS then goto wrong_user; if ^request.proxy then goto wrong_user; /* wrong_user unless proxy request */ if project ^= before (after (request.proxy_name, "."), ".") then goto wrong_user; end; end; end; /* end check user */ user_matches = "1"b; /* true if we fell thru ok or if ^check_user */ wrong_user: /* come here from above as soon as user is found not to match */ if user_matches then total_for_user = total_for_user + 1; /* count requests belonging to the specified user */ /* Now see if the request is deferred or not, and update the request position counter. If printing position, we count the request even if we are not listing it, so we will know the positions of subsequent requests that we do list. So we make this check before eliminating the request by going to skip. But, if -immediate was given, we not only don't list deferred requests, but we don't count them when computing the positions of other requests. We assume the deferred requests will be passed by the other requests whose positions we will print. */ if info.immediate | read_all then do; /* check for immediate first */ if info.request_type = IO | info.request_type = OUTPUT then /* for I/O requests */ if request.state = STATE_DEFERRED then goto deferred_request; /* the decision is very simple */ if info.request_type = ABS then do; /* for absentee, it is a bit more complicated */ if request.state < STATE_ELIGIBLE then do; if request.user_deferred_until_time then if request.deferred_time > time_now then goto deferred_request; if request.user_deferred_indefinitely then goto deferred_request; if request.operator_deferred_until_time then if request.deferred_time > time_now then goto deferred_request; if request.operator_deferred_indefinitely then goto deferred_request; if request.cpu_time_limit then goto deferred_request; end; end; /* retrieval requests do not have a non-immediate mode */ goto immediate_request; deferred_request: deferred_count = deferred_count + 1; /* count deferred requests for totals line */ if info.immediate then goto skip; immediate_request: end; /* end immediate checking */ position = position + 1; /* this request counts for position computation */ /* Now start checking whether we want to list this request or count it in the totals */ /* First, check the user match switch that we set above */ if ^user_matches then goto skip; /* Copy a few variables out of the queue_msg_hdr part of the request structure */ dirname = request.dirname; ename = request.ename; msg_time = request.msg_time; state = request.state; if state > hbound (state_names, 1) | state < lbound (state_names, 1) then state = -1; /* See if the ID, dirname, and entry name match */ if info.id_sw then if ^match_request_id_ (msg_time, (info.request_id)) then goto skip; if info.dirname_sw then if dirname ^= info.dirname then do; if aguid = ""b then goto skip; /* if we don't have UID of info.dirname, don't try UID match */ call expand_pathname_ (dirname, rqdd, rqde, code); if code ^= 0 then goto skip; call hcs_$status_long (rqdd, rqde, (1), addr (branch_status), null, code); if code ^= 0 then goto skip; if aguid ^= branch_status.unique_id then goto skip; end; if info.ename_sw then if ename ^= info.ename then do; call match_star_name_ (ename, (info.ename), code); if code ^= 0 then if ^check_abs_name then goto skip; else do; /* user left off the .absin */ if ename ^= abs_name then do; call match_star_name_ (ename, abs_name, code); if code ^= 0 then goto skip; end; end; end; /* These checks just apply to absentee requests */ if info.request_type = ABS then do; if info.resource_sw then do; if request.len_resource = 0 then goto skip; if index (request.resource, info.resource_name) = 0 then goto skip; end; if info.deferred_indefinitely then if ^request.user_deferred_indefinitely & ^request.operator_deferred_indefinitely then goto skip; if info.sender_sw then /* check sender (RJE station) */ if request.sender ^= info.sender then do; call match_star_name_ ((request.sender), (info.sender), code); if code ^= 0 then goto skip; end; /* Later, add more checks to select absentee requests by their state, and by their cpu time and resource requirements, mainly for the operator's use. */ end; /* end absentee only checks */ if info.request_type = OUTPUT then do; if info.forms_sw then do; if dprint_msg.version < dprint_msg_version_5 then auto_forms_name = rtrim (dprint_msg.forms); else auto_forms_name = dprint_msg.forms_name; if length (auto_forms_name) = 0 then goto skip; if info.forms_name ^= "" then if index (auto_forms_name, rtrim (info.forms_name)) = 0 then goto skip; end; end; /* end output only checks */ /* Arriving here, we have selected this request, either for printing or counting in the totals */ total_selected = total_selected + 1; /* increment number of requests */ /* The following loops apply to request_info data */ allsw = "0"b; offs, ons, af_flag_str = ""; if rqi_sw then do; /* request_info */ if substr (info.com_rqi, 1, 1) = "1"b then do; /* bit 1 means "all" */ allsw = "1"b; info.com_rqi = "11111111111"b; end; do i = 1 to length (info.com_rqi); if substr (info.com_rqi, i, 1) = "1"b then do; call buffer_com_element (i); rqi_buffered = "1"b; end; end; if info.request_type = ABS then do; if allsw then info.abs_rqi = "1111111111111"b; do i = 1 to length (info.abs_rqi); if substr (info.abs_rqi, i, 1) = "1"b then do; call buffer_abs_element (i); rqi_buffered = "1"b; end; end; goto skip; end; if info.request_type = IO | info.request_type = OUTPUT then do; if allsw then info.output_rqi = "11111111111"b; do i = 1 to length (info.output_rqi); if substr (info.output_rqi, i, 1) = "1"b then do; call buffer_output_element (i); rqi_buffered = "1"b; end; end; goto skip; end; if info.request_type = RETV then do; if allsw then info.retv_rqi = "1111"b; do i = 1 to length (info.retv_rqi); if substr (info.retv_rqi, i, 1) = "1"b then do; call buffer_retv_element (i); rqi_buffered = "1"b; end; end; goto skip; end; if info.request_type = IMFT then do; if allsw then info.imft_rqi = "111"b; do i = 1 to length (info.imft_rqi); if substr (info.imft_rqi, i, 1) = "1"b then do; call buffer_imft_element (i); rqi_buffered = "1"b; end; end; goto skip; end; end; if info.total_sw then do; if info.position_sw then do; /* print positions of selected requests */ if total_selected + static_total_selected = 1 then do; /* if first one */ psn_s = info.output_count + 8; /* remember where the s in Positions is */ call ioa_$rsnnl ("Positions:^2x^d,", buffer, len, position); call put_buffer; psn_ll = len; /* the position string could get extremely long */ call get_line_length_ ("user_output", ll, code); /* so split it into terminal-sized sections */ if code ^= 0 then ll = DEFAULT_LINE_LTH; /* guess low */ if ll < TOO_SMALL_LINE_LTH then ll = DEFAULT_LINE_LTH; end; else do; call ioa_$rsnnl ("^x^d,", buffer, len, position); if psn_ll + len > ll then do; /* output lines split by the tty dim look sloppy */ call put_message (NL); psn_ll = 0; end; call put_buffer; psn_ll = psn_ll + len; end; end; /* end print positions */ goto skip; /* just totals, so don't print anything more about the request */ end; /* Not just totals. We will list this request, so start formatting some of its parameters. */ rqid = request_id_ (msg_time); if ^long_id then rqid = substr (rqid, 7, 8); /* If normal (not long) output form specified, summarize the request in a single line */ if ^info.long_sw then do; if total_selected + static_total_selected = 1 then do; /* if we are about to list our first request */ call put_message (NL); /* put blank line after totals line */ if print_user_column then do; /* if admin, for all users, print heading */ call ioa_$rs ("User^31t^[^7x^]ID^[^18x^;^7x^]^[Input segment^s^;^[Pathname^;Entry name^]^]", buffer, len, info.position_sw, long_id, (info.request_type = ABS), info.path_sw); call put_buffer; end; end; /* Build up the line one field at a time. Some fields are optional, depending on arguments given by user and passed in info.switches */ if print_user_column then do; /* if listing more than one user's requests */ call ioa_$rsnnl ("^30a", buffer, len, sender_id); /* say who this one is from */ call put_buffer; end; if info.position_sw then do; call ioa_$rsnnl ("^3d)^x", buffer, len, position); call put_buffer; end; call ioa_$rsnnl ("^a", buffer, len, rqid); call put_buffer; if info.path_sw then call ioa_$rsnnl ("^x^a^[>^]^a", buffer, len, dirname, (dirname ^= ">"), ename); else call ioa_$rsnnl ("^x^a", buffer, len, ename); call put_buffer; deferred_abs = ""b; if ^info.brief_sw then do; /* don't print request state if -brief given */ if info.request_type = ABS & state = 0 then do; /* check for deferred but unprocessed abs jobs */ if request.user_deferred_indefinitely then deferred_abs = "1"b; else if request.user_deferred_until_time then if request.deferred_time > time_now then deferred_abs = "1"b; if deferred_abs then call put_message (" (unprocessed, deferred"); end; if state > 0 then do; /* print state, if nonzero */ if state > hbound (state_names, 1) then state = -1; /* avoid fault if bad state */ call ioa_$rsnnl ("^x(^a^[^;)^]", buffer, len, state_names (state), (info.request_type = ABS & state = STATE_DEFERRED)); call put_buffer; end; end; /* The rest of these only apply to absentee requests */ if info.request_type = ABS then do; if ^info.brief_sw then do; if state = STATE_DEFERRED | deferred_abs then do; call explain_abs_deferral; call put_message (")"); end; if request.len_comment > 0 then do; call ioa_$rsnnl ("^x""^a""", buffer, len, request.comment); call put_buffer; end; if info.resource_sw then do; /* print resources even in normal mode */ i = index (request.resource, " "); /* if blanks in resource string, quote it */ call ioa_$rsnnl ("^x-rsc ^[""^]^a^[""^]", buffer, len, (i > 0), request.resource, (i > 0)); call put_buffer; end; end; /* end not -brief */ end; /* end absentee */ if info.request_type = OUTPUT then do; if ^info.brief_sw then do; if info.forms_sw then do; if dprint_msg.version < dprint_msg_version_5 then auto_forms_name = rtrim (dprint_msg.forms); else auto_forms_name = dprint_msg.forms_name; i = index (auto_forms_name, " "); call ioa_$rsnnl ("^x-forms ^[""^]^a^[""^]", buffer, len, (i > 0), auto_forms_name, (i > 0)); call put_buffer; end; end; end; /* end output */ call put_message (NL); /* we finally got to the end of that line */ end; /* end normal (not long) output mode */ /* Long form. Print each variable in the request in a separate line. The first few variables are common to all request types. */ else do; /* long form */ call put_message (NL); /* insert leading NL */ if print_user_column then do; /* if more than one user's requests are being listed */ call ioa_$rs ("User:^21t^a", buffer, len, sender_id); call put_buffer; end; aclass_string = ""; call convert_authorization_$to_string_short (access_class, aclass_string, code); if aclass_string ^= "" then do; /* print access class */ call ioa_$rs ("Access class:^21t^a", buffer, len, aclass_string); call put_buffer; end; if info.position_sw then do; call ioa_$rs ("Position in queue:^21t^d", buffer, len, position); call put_buffer; end; call ioa_$rs ("Request ID:^21t^a", buffer, len, rqid); call put_buffer; time = date_time_$format ("date_time", msg_time, "", ""); call ioa_$rs ("Time queued:^21t^a", buffer, len, time); call put_buffer; call ioa_$rs ("^[Input segment:^;Pathname:^]^21t^a^[>^]^a", buffer, len, (info.request_type = ABS), dirname, (dirname ^= ">"), ename); call put_buffer; call ioa_$rsnnl ("State:^21t^a", buffer, len, state_names (state)); call put_buffer; if state = STATE_DEFERRED & info.request_type = ABS then call explain_abs_deferral; call put_message (NL); /* Now print per-request-type information */ /* Absentee request */ if info.request_type = ABS then do; /* First print information that's always there */ if request.restartable then str = "yes"; else str = "no"; call ioa_$rs ("Restartable:^21t^a", buffer, len, str); call put_buffer; /* Then print values of optional items, but only if they were specified in the request */ if request.notify then call put_message (Notify_msg); if request_version > ABS_VER_4 then do; /* The Following two messages only apply to newer request_version */ if request.restarted then call put_message (Restarted_msg); if request.truncate_absout then call put_message (Truncate_msg); end; if request.user_deferred_until_time then do; time = date_time_$format ("date_time", request.deferred_time, "", ""); call ioa_$rs ("Deferred time:^21t^a", buffer, len, time); call put_buffer; end; if request.user_deferred_indefinitely then call put_message_nl ("Deferred: indefinitely"); if request.arg_count > 0 then do; expandlen = request.len_args + 25; allocate args_con_blanks in (region) set (expandp); allocate args_sans_blanks in (region) set (scrunchedp); argl = request.arg_lengths (1); curarg_start = 1; args_sans_blanks = substr (request.args, 1, argl); call ioa_$rs ("Argument string:^21t""^a""", args_con_blanks, expandedlen, args_sans_blanks); info.output_count = info.output_count + expandedlen; substr (cstrng, info.output_count - expandedlen) = substr (args_con_blanks, 1, expandedlen); curarg_start = curarg_start + argl; do argx = 2 to request.arg_count; argl = request.arg_lengths (argx); args_sans_blanks = substr (request.args, curarg_start, argl); call ioa_$rs ("^21t""^a""", args_con_blanks, expandedlen, args_sans_blanks); info.output_count = info.output_count + expandedlen; substr (cstrng, info.output_count - expandedlen) = substr (args_con_blanks, 1, expandedlen); curarg_start = curarg_start + argl; end; free scrunchedp -> args_sans_blanks in (region); free expandp -> args_con_blanks in (region); end; if request.max_cpu_time > 0 then do; call ioa_$rs ("CPU limit:^21t^d seconds", buffer, len, request.max_cpu_time); call put_buffer; end; if request.len_output > 0 then do; call ioa_$rs ("Output file:^21t^a", buffer, len, request.output_file); call put_buffer; end; if aim_check_$greater (request.requested_authorization, access_class) then do; aclass_string = ""; call convert_authorization_$to_string_short (request.requested_authorization, aclass_string, code); if aclass_string ^= "" then do; call ioa_$rs ("Requested auth:^21t^a", buffer, len, aclass_string); call put_buffer; end; end; if request.len_proxy > 0 then do; call ioa_$rs ("Proxy user:^21t^a", buffer, len, request.proxy_name); call put_buffer; end; if request.len_resource > 0 then do; call ioa_$rs ("Resources required:^21t^a", buffer, len, request.resource); call put_buffer; end; if request.len_sender > 0 then do; call ioa_$rs ("Sender:^21t^a", buffer, len, request.sender); call put_buffer; end; if request.len_comment > 0 then do; call ioa_$rs ("Comment:^21t^a", buffer, len, request.comment); call put_buffer; end; if request.request_version > ABS_VER_5 /* version 6 elements */ then do; if request.no_start_up then do; str = "yes"; call ioa_$rs ("No start_up:^21t^a", buffer, len, str); call put_buffer; end; if request.initial_ring ^= -1 then do; call ioa_$rs ("Initial ring:^21t^d", buffer, len, request.initial_ring); call put_buffer; end; if request.len_homedir > 0 then do; call ioa_$rs ("Home dir:^21t^a", buffer, len, request.home_dir); call put_buffer; end; if request.len_initproc > 0 then do; call ioa_$rs ("Initial proc:^21t^a", buffer, len, substr (request.init_proc, 1, request.len_initproc)); call put_buffer; end; end; end; /* I/O daemon request */ else if info.request_type = IO | info.request_type = OUTPUT then do; /* Print stuff that's always given */ if lbound (pp_request_type, 1) <= dprint_msg.output_module & dprint_msg.output_module <= hbound (pp_request_type, 1) then do; call ioa_$rs ("Punch format:^21t^a", buffer, len, pp_request_type (dprint_msg.output_module)); call put_buffer; end; call ioa_$rs ("Copies:^21t^d", buffer, len, dprint_msg.copies); call put_buffer; if dprint_msg.delete_sw then str = "yes"; else str = "no"; call ioa_$rs ("Delete:^21t^a", buffer, len, str); call put_buffer; /* Then print optional stuff, but only if it was given */ if dprint_msg.heading ^= "" then do; if substr (dprint_msg.heading, 1, 5) = " for " then i = 6; else i = 1; /* start at char one if dprint added " for" */ call ioa_$rs ("Heading:^21t^a", buffer, len, substr (dprint_msg.heading, i)); call put_buffer; end; if dprint_msg.destination ^= "" then do; call ioa_$rs ("Destination:^21t^a", buffer, len, dprint_msg.destination); call put_buffer; end; if dprint_msg.top_label = dprint_msg.bottom_label & dprint_msg.top_label_lth > 0 then do; call ioa_$rs ("Labels:^21t^a", buffer, len, dprint_msg.top_label); call put_buffer; end; else do; if dprint_msg.top_label_lth > 0 then do; call ioa_$rs ("Top label:^21t^a", buffer, len, dprint_msg.top_label); call put_buffer; end; if dprint_msg.bottom_label_lth > 0 then do; call ioa_$rs ("Bottom label:^21t^a", buffer, len, dprint_msg.bottom_label); call put_buffer; end; end; if dprint_msg.version < dprint_msg_version_5 then auto_forms_name = rtrim (dprint_msg.forms); else auto_forms_name = dprint_msg.forms_name; if auto_forms_name ^= "" then do; call ioa_$rs ("Forms:^21t^a", buffer, len, auto_forms_name); call put_buffer; end; if dprint_msg.notify then call put_message (Notify_msg); if dprint_msg.line_nbrs then if dprint_msg.version > dprint_msg_version_3 then call put_message (line_nbrs_msg); if dprint_msg.defer_until_process_termination then call put_message (DUPT_msg); modes = ""; if dprint_msg.nep then modes = modes || "-no_endpage "; if dprint_msg.non_edited then modes = modes || "-non_edited "; if dprint_msg.single then modes = modes || "-single "; if dprint_msg.truncate then modes = modes || "-truncate "; if dprint_msg.no_separator then modes = modes || "-no_separator "; if dprint_msg.esc then modes = modes || "-esc "; if dprint_msg.lmargin > 0 then do; call ioa_$rsnnl ("^a ^d ", tbf, j, "-indent", dprint_msg.lmargin); modes = modes || tbf; end; if dprint_msg.line_lth > 0 then do; call ioa_$rsnnl ("^a ^d ", tbf, j, "-line_length", dprint_msg.line_lth); modes = modes || tbf; end; if dprint_msg.page_lth > 0 then do; call ioa_$rsnnl ("^a ^d ", tbf, j, "-page_length", dprint_msg.page_lth); modes = modes || tbf; end; if modes ^= "" then do; call ioa_$rs ("Options:^21t^a", buffer, len, modes); call put_buffer; end; if dprint_msg.chan_stop_path_lth > 0 then do; call ioa_$rs ("Channel stops:^21t^a", buffer, len, dprint_msg.chan_stop_path); call put_buffer; end; end; /* Retrieval request */ else if info.request_type = RETV then do; if retv_request.new_dirname ^= "" then do; call ioa_$rs ("New pathname:^21t^a^[>^]^a", buffer, len, retv_request.new_dirname, (retv_request.new_dirname ^= ">"), retv_request.new_ename); call put_buffer; end; if retv_request.from_time ^= 0 then do; time = date_time_$format ("date_time", retv_request.from_time, "", ""); call ioa_$rs ("From Time:^21t^a", buffer, len, time); call put_buffer; end; if retv_request.to_time ^= 0 & ^retv_request.previous then do; time = date_time_$format ("date_time", retv_request.to_time, "", ""); call ioa_$rs ("To Time:^21t^a", buffer, len, time); call put_buffer; end; modes = ""; if retv_request.subtree then modes = modes || "subtree "; if retv_request.notify then modes = modes || "notify "; if retv_request.previous then modes = modes || "previous "; if modes ^= "" then do; call ioa_$rs ("Options:^21t^a", buffer, len, modes); call put_buffer; end; end; /* end retrieval request */ end; /* end long output mode */ /* As the label suggests, we come here to skip a request that does not meet the user-specified criteria */ skip: /* Free the storage occupied by this request */ free reqp -> based_dummy in (region); /* This will correctly free any one of the request types */ /* Read another request from the queue */ old_ms_id = mseg_message_info.ms_id; /* copy message id of last request, for use in incremental read */ retrying = ""b; retry_2: reqp, requestp, dmp = null; /* init these to avoid faults */ local_mseg_message_info.ms_id = old_ms_id; local_mseg_message_info.message_code = MSEG_READ_AFTER_SPECIFIED; local_mseg_message_info.own = ^read_all; call message_segment_$read_message_index (info.mseg_idx, areap, mseg_message_info_ptr, code); if ^retrying then /* retry the read once, if queue has been salvaged */ if code = error_table_$bad_segment then do; retrying = "1"b; goto retry_2; end; if (rqi_sw & rqi_buffered & allsw) then do; rqi_buffered = "0"b; call put_message (NL); /* insert NL after each request entity */ end; go to loop; /* End of loop through all requests. The statement at label "loop" checks code and comes right back here if it is nonzero. We exit the loop normally if code = error_table_$no_message, and abnormally if it is any other nonzero value. */ mess_err: if reqp ^= null then /* free up allocated space if necessary */ free reqp -> request in (region); /* This will correctly free any one of the request types */ if code ^= 0 then /* if encounter no message - not an error */ if code ^= error_table_$no_message then /* otherwise return code to caller */ return_code: a_code = code; /* Normal exit. Put totals figures into the header line that we left room for at the top of the temp segment. */ fin: /* But first, add totals for this queue to cumulative totals */ if rqi_sw then do; /* no more formatting neccessary for rqi */ info.output_count = info.output_count - 1; /* reflect actual output count */ return; end; info.user_select_count = info.user_select_count + total_for_user; /* tell caller how many he had in the queue */ info.select_count = info.select_count + total_selected; /* and how many we listed */ info.message_count = info.message_count + messcount; /* and how many total requests were in the queue */ /* End a partial "positions" line, if there is one */ if info.total_sw & info.position_sw & total_selected > 0 then do; /* if printing positions, end the line */ if total_selected = 1 then substr (cstrng, psn_s, 2) = ": "; /* make Positions: into Position: */ substr (cstrng, info.output_count - 1, 1) = "."; /* make trailing , into . */ call put_message (NL); /* end the line */ end; /* Report on bad requests in this queue, if any */ if n_bad_vrsn > 0 & (info.total_sw | n_bad_vrsn ^= total_selected) then do; call ioa_$rs ("^12x^d requests had obsolete or incorrect formats", buffer, len, n_bad_vrsn); call put_buffer; end; /* And finally, add up totals for queues 0 and 1 if appropriate */ if (info.abs_q_1 & info.queue = 1 & static_header_position > 0) then do; /* if this is Q 1 and there is Q 0 data */ messcount = messcount + static_messcount; /* add Q 0 total messages to those for Q 1 */ total_selected = total_selected + static_total_selected; /* likewise for total selected */ end; /* Now, if -all (or search_all) was given, eliminate any heading lines that have only zeros in them */ if (info.all_opt_sw /* if -all was given */ & (messcount = 0 & ^no_totals)) /* and we know this queue is empty */ | (info.search_all /* or if the search_all option is in effect */ & total_selected = 0) /* and we selected no requests from this queue */ then info.output_count = info.output_count - header_length - 1; /* then omit the heading */ /* Otherwise, fill in the header */ else do; if (info.queue = 0 & info.abs_q_1) then do; /* if treating abs Q 0 as Q 1 */ static_header_position = header_position; /* save some stuff for use when we list Q 1 */ static_total_selected = total_selected; static_messcount = messcount; static_deferred_count = deferred_count; static_position = position; static_psn_s = psn_s; static_ll = ll; end; if ^((info.all_opt_sw | info.search_all) & info.total_sw) then /* single space the totals lines for -a -tt */ substr (cstrng, info.output_count, 1) = NL; /* put new line at end of information for this queue */ else info.output_count = info.output_count - 1; /* this is where the NL would have gone */ /* Decide if we want to print Queue N: R requests. T total requests. or Queue N: R requests. or Queue N: T total requests. */ print_requests = "1"b; /* start by assuming we will print R requests */ if ^no_totals then /* if we are going to print T total requests, we might want to leave out R requests */ if messcount = 0 /* 0 requests. 0 total requests. looks dumb */ | (messcount = total_selected /* as does N requests. N total requests (N the same) */ & info.admin_sw /* when you said -admin */ & ^select_sw) /* and didn't give any other selection arguments */ then print_requests = ""b; /* so leave out R requests in those cases */ if total_selected = 1 then s = ""; else s = "s"; /* place queue number + number of requests found in header */ if info.request_type = ABS then queue_string = "Absentee"; else if info.request_type = RETV then queue_string = "Retriever"; else do; queue_string = info.queue_name; end; i = info.queue; /* get queue priority number */ if i = 0 & info.abs_q_1 then i = 1; /* fake queue number if necessary */ call ioa_$rsnnl ("^[Foreground:^x^2s^;^a queue ^d:^4x^]^[^d request^a.^]", buffer, len, (i = -1), queue_string, i, print_requests, total_selected, s); i = header_length - 1; /* and pad remainder of header with blanks */ substr (cstrng, header_position, i) = substr (buffer, 1, len); substr (cstrng, header_position + i, 1) = NL;/* place a new line at end of header */ if ^no_totals then do; /* if caller has correct access put total number in header */ header_position = header_position + len; if messcount = 1 then s = ""; else s = "s"; call ioa_$rsnnl (" ^d total request^a^[^x(^d deferred)^].", buffer, len, messcount, s, (deferred_count > 0), deferred_count); substr (cstrng, header_position, len) = substr (buffer, 1, len); end; end; /* end fill in header */ return; /* ********** INTERNAL PROCEDURES ********** */ put_buffer: proc; /* replaces about 35 instances of these two statements */ info.output_count = info.output_count + len; substr (cstrng, info.output_count - len) = substr (buffer, 1, len); return; end put_buffer; /* ********** */ put_message: proc (message); dcl message char (*); nlsw = ""b; putmsg: info.output_count = info.output_count + length (message); substr (cstrng, info.output_count - length (message)) = message; if nlsw then do; info.output_count = info.output_count + 1; substr (cstrng, info.output_count - 1) = NL; end; return; put_message_nl: entry (message); dcl nlsw bit (1) aligned; nlsw = "1"b; goto putmsg; end put_message; /* ********** */ cleaner_up: proc; if reqp ^= null then free reqp -> request in (region); if expandp ^= null then free expandp -> args_con_blanks in (region); if expandp ^= null then free scrunchedp -> args_sans_blanks in (region); return; end cleaner_up; /* ********** */ explain_abs_deferral: proc; if request.operator_deferred_indefinitely then call put_message (" indefinitely by operator"); else if request.cpu_time_limit then call put_message (" because of cpu time limit"); else if request.resources_unavailable then call put_message (" - requested resources unavailable"); else if request.queue_limit then call put_message (" because of queue limit"); else if request.user_limit then call put_message (" because of user limit"); else if request.load_control then call put_message (" because of load control group limits"); else if request.user_deferred_until_time then do; call put_message (" by user"); if ^info.long_sw then do; /* if summarizing it on one line, append deferred time */ time = date_time_$format ("^ ^