



		    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 <id> <user> and <user> <id> */
						/* where <user> 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 <foo's 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 ("^<date> ^<time>", request.deferred_time, "", "");
						/* format the time */
		call put_message (" to ");
		call put_message ((time));		/* use just mm/dd/yy hhmm.t */
	     end;
	end;
	else if request.user_deferred_indefinitely
	then call put_message (" indefinitely by user");

	return;

     end explain_abs_deferral;

/* ********** */

put_flag:
     proc (the_flag, the_flag_str);

dcl  the_flag bit (1) unal parm;
dcl  the_flag_str char (*) parm;

	if afsw
	then call ioa_$rsnnl ("^a^[^^^]^a,", af_flag_str, rs_len, af_flag_str, ^the_flag, the_flag_str);
	else if the_flag
	then ons = ons || the_flag_str || ", ";
	else offs = offs || the_flag_str || ", ";
	return;
     end put_flag;
%page;

buffer_abs_element:
     proc (abx);

dcl  abx fixed bin;

	goto abs_case (abx);

abs_case (1):					/* max_cpu_time */
	call ioa_$rsnnl ("^[cpu limit:^34t^d^/^;^d^x^]", buffer, len, ^afsw, request.max_cpu_time);
	goto abs_buffer;

abs_case (2):					/* output_file */
	if request.output_file = ""
	then call ioa_$rsnnl ("^[output file:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[output file:^34t^a^/^;^a^x^]", buffer, len, ^afsw, request.output_file);
	goto abs_buffer;

abs_case (3):					/* proxy_name */
	if request.proxy_name = ""
	then call ioa_$rsnnl ("^[proxy name:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[proxy name:^34t^a^/^;^a^x^]", buffer, len, ^afsw, request.proxy_name);
	goto abs_buffer;

abs_case (4):					/* resource */
	if request.resource = ""
	then call ioa_$rsnnl ("^[resource:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[resource:^34t^a^/^;^a^x^]", buffer, len, ^afsw, request.resource);
	goto abs_buffer;

abs_case (5):					/* sender */
	if request.sender = ""
	then call ioa_$rsnnl ("^[sender:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[sender:^34t^a^/^;^a^x^]", buffer, len, ^afsw, request.sender);
	goto abs_buffer;

abs_case (6):					/* comment */
	if request.comment = ""
	then call ioa_$rsnnl ("^[comment:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[comment:^34t^a^/^;^a^x^]", buffer, len, ^afsw, request.comment);
	goto abs_buffer;

abs_case (7):					/* args */
	if request.arg_count <= 0
	then do;
	     call ioa_$rsnnl ("^[args:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	     goto abs_buffer;
	end;
	else do;
	     curarg_start = 1;
	     do argx = 1 to request.arg_count;
		argl = request.arg_lengths (argx);
		call ioa_$rsnnl ("^[^[args:^]^34t""^a""^/^;^s""^a""^x^]", buffer, len, ^afsw, (argx = 1),
		     substr (request.args, curarg_start, argl));
		call put_buffer;
		curarg_start = curarg_start + argl;
	     end;
	end;
	return;					/* we already buffered output, so return here */

abs_case (8):					/* home_dir */
	if request.home_dir = ""
	then call ioa_$rsnnl ("^[home dir:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[home dir:^34t^a^/^;^a^x^]", buffer, len, ^afsw, request.home_dir);
	goto abs_buffer;

abs_case (9):					/* init_proc */
	if request.init_proc = ""
	then call ioa_$rsnnl ("^[init proc:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[init proc:^34t^a^/^;^a^x^]", buffer, len, ^afsw, request.init_proc);
	goto abs_buffer;

abs_case (10):					/* initial_ring */
	call ioa_$rsnnl ("^[initial ring:^34t^d^/^;^d^x^]", buffer, len, ^afsw, request.initial_ring);
	goto abs_buffer;

abs_case (11):					/* authorization */
	aclass_string = "";
	call convert_authorization_$to_string_short (request.requested_authorization, aclass_string, code);
	if aclass_string ^= ""
	then call ioa_$rsnnl ("^[authorization:^34t^a^/^;^a^x^]", buffer, len, ^afsw, aclass_string);
	else call ioa_$rsnnl ("^[authorization:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	goto abs_buffer;

abs_case (12):					/* deferred_time */
	time = date_time_$format ("date_time", request.deferred_time, "", "");
	call ioa_$rsnnl ("^[deferred time:^34t^a^/^;^a^x^]", buffer, len, ^afsw, time);
	goto abs_buffer;

abs_case (13):					/* deferred_by */
	if request.user_deferred_until_time
	then str = request.name;
	else if request.operator_deferred_until_time
	then str = "Operator";
	else str = """";
	call ioa_$rsnnl ("^[deferred by:^34t^a^/^;^a^x^]", buffer, len, ^afsw, str);

abs_buffer:
	call put_buffer;
	return;

     end buffer_abs_element;

%page;
buffer_com_element:
     proc (cbx);

dcl  cbx fixed bin;

	goto com_case (cbx);

com_case (1):					/* all */
	allsw = "1"b;
	return;

com_case (2):					/* request_id */
	rqid = request_id_ (msg_time);
	call ioa_$rsnnl ("^[message ident:^34t^a^/^;^a^x^]", buffer, len, ^afsw, rqid);
	goto com_buffer;

com_case (3):					/* submitter */
	call ioa_$rsnnl ("^[submitter:^34t^a^/^;^a^x^]", buffer, len, ^afsw, sender_id);
	goto com_buffer;

com_case (4):					/* position */
	call ioa_$rsnnl ("^[position:^34t^d^/^;^d^x^]", buffer, len, ^afsw, position);
	goto com_buffer;

com_case (5):					/* directory */
	call ioa_$rsnnl ("^[directory:^34t^a^/^;^a^x^]", buffer, len, ^afsw, request.dirname);
	goto com_buffer;

com_case (6):					/* entry */
	call ioa_$rsnnl ("^[entry:^34t^a^/^;^a^x^]", buffer, len, ^afsw, request.ename);
	goto com_buffer;

com_case (7):					/* enter_time */
	time = date_time_$format ("date_time", request.msg_time, "", "");
	call ioa_$rsnnl ("^[enter time:^34t^a^/^;^a^x^]", buffer, len, ^afsw, time);
	goto com_buffer;


com_case (8):					/* message_type */
	str = "Unknown type";
	if request.message_type = 0
	then str = "absentee";
	else if request.message_type = 1
	then str = "print";
	else if request.message_type = 2
	then str = "punch";
	else if request.message_type = 3
	then str = "tape";
	else if request.message_type = 4
	then str = "retrieval";
	else if request.message_type = 5
	then str = "imft";
	call ioa_$rsnnl ("^[message type:^34t^a^/^;^a^x^]", buffer, len, ^afsw, str);
	goto com_buffer;

com_case (9):					/* queue */
	call ioa_$rsnnl ("^[queue:^34t^d^/^;^d^x^]", buffer, len, ^afsw, request.orig_queue);
	goto com_buffer;

com_case (10):					/* state */
	call ioa_$rsnnl ("^[state:^34t^a^/^;^a^x^]", buffer, len, ^afsw, state_names (request.state));
	goto com_buffer;

com_case (11):					/* request_flags */
	call put_flag (request.notify, "notify");
	if info.request_type = ABS
	then do;
	     call put_flag (request.delete_sw, "delete");
	     call put_flag (request.defer_until_process_termination, "dupt");
	     call put_flag (request.restartable, "restartable");
	     call put_flag (request.proxy, "proxy");
	     call put_flag (request.set_bit_cnt, "set_bit_cnt");
	     call put_flag (request.operator_deferred_indefinitely, "dfi");
	     call put_flag (request.secondary_ok, "secondary");
	     call put_flag (request.truncate_absout, "truncate");
	     call put_flag (request.restarted, "restarted");
	     call put_flag (request.no_start_up, "nostartup");
	     call put_flag (request.resources_unavailable, "noresources");
	end;
	else if info.request_type = OUTPUT | info.request_type = IO
	then do;
	     call put_flag (request.delete_sw, "delete");
	     call put_flag (request.defer_until_process_termination, "dupt");
	     call put_flag (dprint_msg.nep, "noendpage");
	     call put_flag (dprint_msg.single, "single");
	     call put_flag (dprint_msg.non_edited, "nonedited");
	     call put_flag (dprint_msg.truncate, "truncate_lines");
	     call put_flag (dprint_msg.esc, "escapes");
	     call put_flag (dprint_msg.center_top_label, "center_top_lbl");
	     call put_flag (dprint_msg.center_bottom_label, "center_bot_lbl");
	     call put_flag (dprint_msg.no_separator, "noseparator");
	     if dprint_msg.version > dprint_msg_version_3
	     then call put_flag (dprint_msg.line_nbrs, "line_nbrs");
	end;
	else if info.request_type = RETV
	then do;
	     call put_flag (substr (retv_request.subtree, 1, 1), "subtree");
	     call put_flag (substr (retv_request.dirs, 1, 1), "dirs");
	     call put_flag (substr (retv_request.segs, 1, 1), "segs");
	     call put_flag (substr (retv_request.previous, 1, 1), "prev");
	end;
	else if info.request_type = IMFT
	then do;
	     call put_flag (ft_request.delete, "delete");
	     call put_flag (ft_request.foreign_user_given, "foreign_user_given");
	     call put_flag (ft_request.foreign_path_given, "foreign_path_given");
	     call put_flag (ft_request.remote_transfer, "remote_trans");
	     call put_flag (ft_request.include_files, "files");
	     call put_flag (ft_request.include_subtrees, "subtrees");

	     if ft_request.directory_creation_mode = REPLACE_DIRECTORIES
	     then do;
		call put_flag ("1"b, "replace_dirs");
		call put_flag ("0"b, "merge_dirs");
	     end;
	     else if ft_request.directory_creation_mode = MERGE_DIRECTORIES
	     then do;
		call put_flag ("0"b, "replace_dirs");
		call put_flag ("1"b, "merge_dirs");
	     end;
	     else do;
		call put_flag ("0"b, "replace_dirs");
		call put_flag ("0"b, "merge_dirs");
	     end;

	     call put_flag (ft_request.extend, "extend");
	     call put_flag (ft_request.update, "update");

	     if (ft_request.extend | ft_request.update)
	     then call put_flag ("0"b, "replace");
	     else call put_flag ("1"b, "replace");

	     if ft_request.chase_control = ALWAYS_CHASE
	     then do;
		call put_flag ("1"b, "always_chase");
		call put_flag ("0"b, "default_chase");
		call put_flag ("0"b, "never_chase");
	     end;
	     else if ft_request.chase_control = DEFAULT_CHASE
	     then do;
		call put_flag ("0"b, "always_chase");
		call put_flag ("1"b, "default_chase");
		call put_flag ("0"b, "never_chase");
	     end;
	     else if ft_request.chase_control = NEVER_CHASE
	     then do;
		call put_flag ("0"b, "always_chase");
		call put_flag ("0"b, "default_chase");
		call put_flag ("1"b, "never_chase");
	     end;
	end;
	if afsw
	then do;
	     len = length (af_flag_str);
	     buffer = substr (af_flag_str, 1, len);
	     goto com_buffer;
	end;
	call get_line_length_ ("user_output", ll, code);
	if code ^= 0
	then ll = DEFAULT_LINE_LTH;
	if ll < TOO_SMALL_LINE_LTH
	then ll = DEFAULT_LINE_LTH;
	pass1 = "1"b;
	psn_ll = 0;
	if ons ^= ""
	then do;
	     onslen = length (rtrim (ons)) - 1;		/* remove last comma */
frag_ons:
	     call ioa_$rsnnl ("^[request flags: ^]^[^34t^]^[^39t^]^[ON:  ^]", buffer, len, (^afsw & pass1),
		(^afsw & pass1), (^afsw & ^pass1), pass1);
	     if len > 0
	     then do;
		if (^afsw & pass1)
		then len_offset = TAB_39;
		else if (^afsw & ^pass1)
		then len_offset = TAB_44;
		call put_buffer;
	     end;
	     call ioa_$rsnnl ("^a", buffer, len, substr (ons, psn_ll + 1, onslen - psn_ll));
	     if len > (ll - len_offset)
	     then do;
		last_comma = (ll - len_offset) - (index (reverse (substr (buffer, 1, (ll - len_offset))), " ,"));
		len = last_comma + 1;
		buffer = substr (buffer, 1, len);
		call put_buffer;
		call put_message_nl ("");		/* NL */
		psn_ll = psn_ll + len;
		pass1 = "0"b;			/* dont reprint the ON/OFF */
		goto frag_ons;
	     end;
	     else call put_buffer;
	     call put_message_nl ("");
	end;

format_off_flags:
	pass1 = "1"b;				/* reset for offs */
	psn_ll = 0;
	if offs ^= ""
	then do;					/* now for the offs */
	     offslen = length (rtrim (offs)) - 1;	/* remove last comma */
frag_offs:
	     call ioa_$rsnnl ("^[request flags: ^]^[^34t^]^[^39t^]^[OFF: ^]", buffer, len, (ons = "" & ^afsw & pass1),
		(^afsw & pass1), (^afsw & ^pass1), pass1);
	     if len > 0
	     then do;
		if (^afsw & pass1)
		then len_offset = TAB_39;
		else if (^afsw & ^pass1)
		then len_offset = TAB_44;
		call put_buffer;
	     end;
	     call ioa_$rsnnl ("^a", buffer, len, substr (offs, psn_ll + 1, offslen - psn_ll));
	     if len > (ll - len_offset)
	     then do;
		last_comma = (ll - len_offset) - (index (reverse (substr (buffer, 1, (ll - len_offset))), " ,"));
		len = last_comma + 1;
		buffer = substr (buffer, 1, len);
		call put_buffer;
		call put_message_nl ("");		/* NL */
		psn_ll = psn_ll + len;
		pass1 = "0"b;			/* dont reprint the ON/OFF */
		goto frag_offs;
	     end;
	     else call put_buffer;
	     call put_message_nl ("");
	end;
	return;

com_buffer:
	call put_buffer;
	return;

     end buffer_com_element;

%page;

buffer_output_element:
     proc (ocx);

dcl  ocx fixed bin;

	goto out_case (ocx);

out_case (1):					/* bit_count */
	call ioa_$rsnnl ("^[bit count:^34t^d^/^;^d^x^]", buffer, len, ^afsw, dprint_msg.bit_count);
	goto out_buffer;

out_case (2):					/* copies */
	call ioa_$rsnnl ("^[copies:^34t^d^/^;^d^x^]", buffer, len, ^afsw, dprint_msg.copies);
	goto out_buffer;

out_case (3):					/* destination */
	if dprint_msg.destination = ""
	then call ioa_$rsnnl ("^[destination:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[destination:^34t^a^/^;^a^x^]", buffer, len, ^afsw, dprint_msg.destination);
	goto out_buffer;

out_case (4):					/* heading */
	if dprint_msg.heading = ""
	then call ioa_$rsnnl ("^[heading:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[heading:^34t^a^/^;^a^x^]", buffer, len, ^afsw, dprint_msg.heading);
	goto out_buffer;

out_case (5):					/* indent */
	call ioa_$rsnnl ("^[indent:^34t^d^/^;^d^x^]", buffer, len, ^afsw, dprint_msg.lmargin);
	goto out_buffer;

out_case (6):					/* line_length */
	if dprint_msg.line_lth = DEFAULT_OUTPUT_LTH
	then str = "default";
	else call ioa_$rsnnl ("^d", str, len, dprint_msg.line_lth);
	call ioa_$rsnnl ("^[line length:^34t^a^/^;^a^x^]", buffer, len, ^afsw, str);
	goto out_buffer;

out_case (7):					/* page_length */
	if dprint_msg.page_lth = DEFAULT_OUTPUT_LTH
	then str = "default";
	else call ioa_$rsnnl ("^d", str, len, dprint_msg.page_lth);
	call ioa_$rsnnl ("^[page length:^34t^a^/^;^a^x^]", buffer, len, ^afsw, str);
	goto out_buffer;

out_case (8):					/* top_label */
	if dprint_msg.top_label = ""
	then call ioa_$rsnnl ("^[top label:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[top label:^34t^a^/^;^a^x^]", buffer, len, ^afsw, dprint_msg.top_label);
	goto out_buffer;

out_case (9):					/* bottom_label */
	if dprint_msg.bottom_label = ""
	then call ioa_$rsnnl ("^[bottom label:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[bottom label:^34t^a^/^;^a^x^]", buffer, len, ^afsw, dprint_msg.bottom_label);
	goto out_buffer;

out_case (10):					/* output_conversion */
	str = "Unknown value";
	if dprint_msg.output_module = 1
	then str = "print";
	else if dprint_msg.output_module = 2
	then str = pp_request_type (2);
	else if dprint_msg.output_module = 3
	then str = pp_request_type (3);
	else if dprint_msg.output_module = 4
	then str = pp_request_type (4);
	else if dprint_msg.output_module = 5
	then str = "plotter";
	call ioa_$rsnnl ("^[output conversion:^34t^a^/^;^a^x^]", buffer, len, ^afsw, str);
	goto out_buffer;

out_case (11):					/* forms */
	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 call ioa_$rsnnl ("^[forms:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[forms:^34t^a^/^;^a^x^]", buffer, len, ^afsw, auto_forms_name);

out_buffer:
	call put_buffer;
	return;

     end buffer_output_element;

%page;
buffer_retv_element:
     proc (rcx);

dcl  rcx fixed bin;

	goto retv_case (rcx);

retv_case (1):					/* from_time */
	time = date_time_$format ("date_time", retv_request.from_time, "", "");
	call ioa_$rsnnl ("^[from time:^34t^a^/^;^a^x^]", buffer, len, ^afsw, time);
	goto retv_buffer;

retv_case (2):					/* new_dir */
	if retv_request.new_dirname = ""
	then call ioa_$rsnnl ("^[new directory:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[new directory:^34t^a^/^;^a^x^]", buffer, len, ^afsw, retv_request.new_dirname);
	goto retv_buffer;

retv_case (3):					/* new_entry */
	if retv_request.new_ename = ""
	then call ioa_$rsnnl ("^[new entryname:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[new entryname:^34t^a^/^;^a^x^]", buffer, len, ^afsw, retv_request.new_ename);
	goto retv_buffer;

retv_case (4):					/* to_time */
	time = date_time_$format ("date_time", retv_request.to_time, "", "");
	call ioa_$rsnnl ("^[to time:^34t^a^/^;^a^x^]", buffer, len, ^afsw, time);

retv_buffer:
	call put_buffer;
	return;

     end buffer_retv_element;

%page;
buffer_imft_element:
     proc (icx);

dcl  icx fixed bin;

	goto imft_case (icx);

imft_case (1):					/* foreign_dir */
	if ft_request.foreign_dirname = "" | ^ft_request.foreign_path_given
	then call ioa_$rsnnl ("^[foreign directory:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[foreign directory:^34t^a^/^;^a^x^]", buffer, len, ^afsw, ft_request.foreign_dirname);
	goto imft_buffer;

imft_case (2):					/* foreign_entry */
	if ft_request.foreign_ename = "" | ^ft_request.foreign_path_given
	then call ioa_$rsnnl ("^[foreign entryname:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[foreign entryname:^34t^a^/^;^a^x^]", buffer, len, ^afsw, ft_request.foreign_ename);
	goto imft_buffer;

imft_case (3):					/* foreign_user */
	if ft_request.foreign_user = "" | ^ft_request.foreign_user_given
	then call ioa_$rsnnl ("^[foreign user:^34t""""^/^;""""^x^]", buffer, len, ^afsw);
	else call ioa_$rsnnl ("^[foreign user:^34t^a^/^;^a^x^]", buffer, len, ^afsw, ft_request.foreign_user);

imft_buffer:
	call put_buffer;
	return;

     end buffer_imft_element;

%page;
%include abs_message_format;
%page;
%include branch_status;
%page;
%include dprint_msg;
%page;
%include "_imft_ft_request";
%page;
%include lar_info;
%page;
%include mseg_message_info;
%page;
%include queue_msg_hdr;
%page;
%include retv_request;
%page;
%include user_abs_attributes;

     end lar_util_;




		    list_abs_requests.pl1           10/28/88  1346.0r w 10/28/88  1257.9      279612



/****^  ************************************************************
        *                                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988                 *
        *                                                          *
        * Copyright, (C) Honeywell Information Systems Inc., 1982  *
        *                                                          *
        * Copyright, (C) Honeywell Information Systems Inc., 1980. *
        *                                                          *
        * Copyright (c) 1972 by Massachusetts Institute of         *
        * Technology and Honeywell Information Systems, Inc.       *
        *                                                          *
        ************************************************************ */



/* format: off */

list_abs_requests:
lar:	procedure;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Command to provide information on absentee, IO Daemon, and retrieval requests	*/
	/*									*/
	/* Status									*/
	/* 0) Modified by E. Stone 9/15/71						*/
	/* 1) Modified by R. Coren 4/17/73 - entry for io_daemon requests added		*/
	/* 2) Modified by J. Stern 6/24/75						*/
	/* 3) Modified by D. Vinograd 5/77 - display queued retrieval requests		*/
	/* 4) Modified by J. C. Whitmore and T. Casey, April 1978 - new arguments		*/
	/* 5) Modified by T. Casey, November 1978 - MR7.0 absentee enhancements		*/
	/* 6) Modified by S. Herbst, 09/10/79 - call lar_util_ with queue entryname		*/
	/* 7) Modified by G. Palter, 22 September 1980 - use site-settable default absentee queue */
	/* 8) Modified by G. Palter, 17 December 1980 - fix pathname used by			*/
	/*				         list_retrieval_requests		*/
	/* 9) Modified by G. Dixon, January 1982 - support eor's user-defined request types,	*/
	/*				   add -print, -punch, -plot			*/
	/* 10) Modified 8/82 by GA Texada to make lar, lrr, lor, and ldr scann all q's by default.*/
	/* 11) Modified 8/84 by C. Marker made lar, lrr, lor, and ldr set the value of id before calling init.
		   */
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(87-08-17,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-04,Lippard), install(88-08-29),MR12.2-1093):
     Incompatible args -bf and -lg now override one another
     (Answering_Service 428, phx15276).
  2) change(88-04-27,Parisek), approve(88-06-13,MCR7913),
     audit(88-08-16,Farley), install(88-08-29),MR12.2-1093):
     Added -forms control argument check.
  3) change(88-08-25,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-04,Lippard), install(88-08-29),MR12.2-1093):
     If multiple instances of -admin PERSON.PROJECT or -user PERSON.PROJECT
     are given, the last instance will now override earlier instances
     instead of diagnosing an error message. (Answering_Service 435,
     phx16126)
                                                   END HISTORY COMMENTS */

    dcl	abs_list_sw		bit(1),
	abs_n_sw			bit(1),
	arg_msg			char(50),
	argptr			ptr,
	arglen			fixed bin(21),
	code			fixed bin(35),
	ctl_arg_given		bit(1),
	default_queue		fixed bin,
	dir			char(168),
	ent			char(32),
	err_msg			char(256),
	finish			fixed bin,
	foreground_sw		bit(1),
	gen_type			char(32),
	i			fixed bin,
	id			char(32),
	ignore_code		fixed bin,
	max_queue			fixed bin,
	min_queue			fixed bin,
	nargs			fixed bin,
	priority			fixed bin,
	rqt_sw			bit(1),
	rs_len                        fixed bin,
	start			fixed bin,
	tp			ptr,
	user_arg			bit(1) aligned;

    dcl	arg			char(arglen) unal based (argptr);

    dcl  (addr, after, before, index, length, min, null, search,
          substr, verify, unspec)
				builtin;

    dcl	cleanup			condition;

    dcl	com_err_			options (variable),
	cu_$arg_count		entry (fixed bin, fixed bin(35)),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr),
	cv_dec_check_		entry (char(*), fixed bin(35)) returns(fixed bin(35)),
	enter_output_request$default_request_type
				entry (char(*), char(*), fixed bin, fixed bin, fixed bin(35)),
	enter_output_request$request_type
				entry (char(*), char(*), char(*), fixed bin, fixed bin, fixed bin(35)),
	expand_pathname_		entry (char(*), char(*), char(*), fixed bin(35)),
	get_temp_segment_		entry (char(*), ptr, fixed bin(35)),
	hcs_$star_		entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr,
				     fixed bin(35)),
	message_segment_$close	entry (fixed bin, fixed bin),
	message_segment_$open	entry (char(*), char(*), fixed bin, fixed bin(35)),
	ioa_			entry() options(variable),
	ioa_$rsnnl		entry() options(variable),
	iod_info_$generic_type	entry (char(*), char(32), fixed bin(35)),
	iod_info_$queue_data	entry (char(*), fixed bin, fixed bin, fixed bin(35)),
	iod_info_$test		entry (char(*)),
	iox_$put_chars		entry (ptr, ptr, fixed bin(21), fixed bin(35)),
	lar_util_			entry (ptr, fixed bin(35)),    
	release_temp_segment_	entry (char(*), ptr, fixed bin(35)),
	request_id_		entry (fixed bin(71)) returns(char(19)),
	sys_log_$command		entry options(variable),
	sys_log_$command_error	entry options(variable),
	system_info_$default_absentee_queue
				entry (fixed bin);

    dcl	CAPITALS			char(26) int static options (constant) init("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
	abs_default_q		fixed bin int static,
	abs_dir			char(168) int static init(">system_control_1"),
	abs_max_q			fixed bin int static,
	io_default_q		fixed bin int static,
	io_max_q			fixed bin int static,
	iod_dir			char(168) int static init(">daemon_dir_dir>io_daemon_dir"),
	not_initialized		bit(1) int static init("1"b),
						/* true when we must get new queue data */
	ret_default_q		fixed bin int static,
	ret_max_q			fixed bin int static,
	retriever_dir		char(168) int static init(">daemon_dir_dir>volume_retriever");

    dcl	error_table_$badopt		fixed bin(35) ext static,
	error_table_$id_not_found	fixed bin(35) ext static,
	error_table_$noarg		fixed bin(35) ext static,
	iox_$user_output		ptr ext static;




	%include lar_info;

    dcl	1 local_info		like info aligned;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


/* 
list_abs_requests:
lar:	proc; 					   MAIN ENTRY POINT				*/

	abs_list_sw = ""b;

lar_init:						/* come here from abs_list entry point to finish  */
	id = "list_abs_requests";
	call init;				/* initialization				*/
	default_queue = abs_default_q;
	max_queue = abs_max_q;
	min_queue = -1;
	dir = abs_dir;
	info.queue_name = "absentee";
	info.request_type = ABS;
	goto JOIN;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


abs_list:	entry (a_arglist_ptr, a_arg_count, a_request_id, a_queue);
						/* entry point used by operator command, abs list */
    dcl	a_arglist_ptr		ptr,		/* ptr to arglist that admin$abs got		*/
	a_arg_count		fixed bin,	/* length of that arglist, including "list"	*/
	a_request_id		fixed bin(71),	/* request ID of job in slot N, if absN arg given */
	a_queue			fixed bin;	/* queue that job from slot N is in		*/

	abs_list_sw = "1"b;				/* remember that we entered here		*/
	goto lar_init;				/* go initialize for listing abs requests	*/


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


list_retrieval_requests:
lrr:	entry;					/* entry used to list retrieval requests	*/
	

	abs_list_sw = ""b;
	id = "list_retrieval_requests";
	call init;
	default_queue = ret_default_q;
	max_queue = ret_max_q;
	min_queue = 1;
	dir = retriever_dir;
	info.queue_name = "volume_retriever";
	info.request_type = RETV;
	go to JOIN;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


list_daemon_requests:
ldr:	entry;					/* entry used to list requests to the io_daemon	*/

	abs_list_sw = ""b;
	id = "list_daemon_requests";
	call init;
	default_queue = io_default_q;			/* start with the default rqt queue data	*/
	max_queue = io_max_q;
	min_queue = 1;
	dir = iod_dir;
	gen_type = "printer";
	info.queue_name = "printer";
	info.request_type = IO;
	go to JOIN;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


list_output_requests:
lor:	entry;
	
	abs_list_sw = ""b;
	id = "list_output_requests";
	call init;
	min_queue = 1;
	dir = iod_dir;
	gen_type = "printer";
	call enter_output_request$default_request_type (gen_type,
	     info.queue_name, default_queue, max_queue, code);
	info.request_type = OUTPUT;
	go to JOIN;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


JOIN:
	abs_n_sw,					/* Initialize control argument switches.	*/
	ctl_arg_given,
	foreground_sw,
	rqt_sw = ""b;

	do i = i to nargs;
	     call get_arg (i);
	     if code ^= 0 then go to CHECK;		/* if no more arguments do consistency check */
	     if index(arg, "-") = 1 then do;		/* if argument is an option match it with acceptable options */
		ctl_arg_given = "1"b;
		if arg = "-user" |
		arg = "-am" | arg = "-admin" then do;
		     if arg = "-user" then user_arg = "1"b; /* remember if it was -user */
		     else user_arg = ""b;		/* or -admin */
		     info.admin_sw = "1"b;
		     call get_arg (i+1);		/* check for optional user name */
		     if code = 0			/* if there is an argument there */
		     & index(arg, "-") ^= 1 then do;	/* and it is not a control arg */
			i = i + 1;		/* remember that we used this arg */
			info.user_sw = "1"b;
			info.person = before (arg, ".");
			info.project = before (after (arg, "."), ".");
			if info.person = "" then info.person = "*";
			if info.project = "" then info.project = "*";
		     end;
		     else if user_arg then do;	/* user name not optional after -user */
			code = error_table_$noarg;
			arg_msg = "After -user";
			goto PRINT_MISS_ARG;
		     end;
		end;

		else if arg = "-lg" | arg = "-long" then do;
		     info.long_sw = "1"b;		/* indicate that long option given */
		     info.brief_sw = "0"b;		/* override a prior brief option */
		     end;
		else if arg = "-tt" | arg = "-total" | arg = "-totals" then
		     info.total_sw = "1"b;		/* indicate that only totals wanted */
		else if arg = "-a" | arg = "-all" then info.all_opt_sw = "1"b; /* we'll check later */
		else if arg = "-search_all" then info.search_all = "1"b;
		else if (arg = "-im" | arg = "-immediate") & info.request_type ^= RETV then
		     info.immediate = "1"b;
		else if arg = "-q" | arg = "-queue" then do;
		     call get_arg (i+1);
		     if code ^= 0 then do;
			arg_msg = "After -queue";
			goto PRINT_MISS_ARG;
		     end;
		     i = i + 1;			/* get next argument - number indicating which queue */
		     if info.q_opt_sw & abs_n_sw then do;
			arg_msg = "The -queue and absN arguments are incompatbile";
PRINT_ARG_ERR:		call ioa_$rsnnl ("^a. ^a", err_msg, rs_len, arg_msg, arg);
			call print_err_msg (-1, 0);
			return;
		     end;
		     info.q_opt_sw = "1"b;		/* remember that it has been given */
		     if (arg = "fg" | arg = "foreground") & info.request_type = ABS then
			priority = -1;
		     else do;
			priority = cv_dec_check_ (arg, code);
						/* see if valid number */
			if code ^= 0 then do;
			     call ioa_$rsnnl ("Illegal queue number ^a", err_msg, rs_len, arg);
			     call print_err_msg (-1, 0);
			     return;
			end;
		     end;
		     start, finish = priority;	/* set first and last queue to be searched */
		end;

		else if arg = "-lgid" | arg = "-long_id" then
		     info.long_id_sw = "1"b;
		else if arg = "-pn" | arg = "-absp" | arg = "-pathname" | arg = "-absolute_pathname" then
		     info.path_sw = "1"b;
		else if arg = "-bf" | arg = "-brief" then do;
		     info.brief_sw = "1"b;
		     info.long_sw = "0"b;		/* override the long option if previously given */
		     end;
		else if arg = "-psn" | arg = "-position" then
		     info.position_sw = "1"b;
		else if arg = "-id" then do;
		     call get_arg (i+1);
		     if code ^= 0 then do;
			arg_msg = "After -id";
PRINT_MISS_ARG:		err_msg = arg_msg;
			call print_err_msg (-1, code);
			return;
		     end;
		     i = i + 1;			/* next arg is the ID */ 
		     if info.id_sw & abs_n_sw then do;
			arg_msg = "The -id and absN arguments are incompatible";
			goto PRINT_ARG_ERR;
		     end;
		     info.id_sw = "1"b;
		     info.request_id = arg;
		end;
		else if arg = "-et" | arg = "-entry" then do;
		     if info.ename_sw & info.dirname_sw then do;
						/* entryname already given */
DUP_ENTRY_PATH:		arg_msg = "Pathname and entry name cannot both be given";
			goto PRINT_ARG_ERR;
		     end;
		     call get_arg (i+1);
		     if code ^= 0 then do;
			arg_msg = "After -entry";
			goto PRINT_MISS_ARG;
		     end;
		     i = i + 1;
		     info.ename_sw = "1"b;
		     info.ename = arg;
		end;

/* Absentee only control arguments */

		else if info.request_type = ABS then do;
		     if arg = "-rsc" | arg = "-resource" | arg = "-resources" then do;
			info.resource_sw = "1"b;
			call get_arg (i+1);		/* look at next arg */
			if code = 0		/* if there is an arg there */
			then if index(arg, "-") ^= 1 then do;
						/* and it's not a control arg */
						/* assume it's a resource name */
				i = i + 1;	/* bump arg index */
				info.resource_name_sw = "1"b;
				info.resource_name = arg;
				if length (arg) > length (info.resource_name) then do;
				     call ioa_$rsnnl ("Resource name too long; limit is ^d characters. ^a",
					err_msg, rs_len, length (info.resource_name), info.resource_name);
				     call print_err_msg (-1, 0);
				     return;
				end;
			     end;
		     end;
		     else if arg = "-dfi" | arg = "-deferred_indefinitely" then
			info.deferred_indefinitely = "1"b;
		     else if arg = "-sender" then do;
			call get_arg (i+1);
			if code ^= 0 then do;
			     arg_msg = "After -sender";
			     goto PRINT_MISS_ARG;
			end;
			i = i + 1;
			info.sender_sw = "1"b;
			info.sender = arg;
		     end;
		     else if arg = "-fg" | arg = "-foreground" then
			foreground_sw = "1"b;
		     else goto BADOPT;		/* no other arguments valid for absentee requests */
		end;				/* end abs control args */

/* I/O daemon only control arguments */

		else if info.request_type = IO then do;
		     if arg = "-rqt" | arg = "-request_type" then do;
			call get_arg (i+1);
			if code ^= 0 then do;
			     arg_msg = "After -request_type";
			     goto PRINT_MISS_ARG;
			end;
			i = i + 1;
			rqt_sw = "1"b;
			gen_type = "";
			call iod_info_$generic_type (arg, gen_type, code);
			if code ^= 0 then
			     if code = error_table_$id_not_found then do;
				call ioa_$rsnnl ("Unknown request type.  ^a", err_msg, rs_len, arg);
				call print_err_msg (-1, 0);
				return;
			     end;
			     else do;
				call ioa_$rsnnl ("Warning -- Unable to check request type ^a.", err_msg, rs_len, arg);
				call print_err_msg (-1, 0);
			     end;
			info.queue_name = arg;	/* set request type component to message segment name */

			call iod_info_$queue_data (info.queue_name, default_queue, max_queue, code);
						/* get new default and max queue numbers */
						/* this will work if the first one did */
		     end;
		     else goto BADOPT;		/* no other arguments valid for daemon requests */
		end;
		else if info.request_type = OUTPUT then do;
		     if arg = "-rqt" | arg = "-request_type" then do;
			call get_arg (i+1);
			if code ^= 0 then do;
			     arg_msg = "After -request_type";
			     goto PRINT_MISS_ARG;
			end;
			i = i + 1;
			rqt_sw = "1"b;
			gen_type = "";
			call enter_output_request$request_type (arg,
			     gen_type, info.queue_name, default_queue,
			     max_queue, code);
			if code ^= 0 then
			     if code = error_table_$id_not_found then do;
				call ioa_$rsnnl ("Unknown request type.  ^a", err_msg, rs_len, arg);
				call print_err_msg (-1, 0);
				return;
			     end;
			     else do;
				call ioa_$rsnnl ("Warning -- Unable to check request type ^a.", err_msg, rs_len, arg);
				call print_err_msg (-1, 0);
			     end;
		     end;
		     else if arg = "-print" | arg = "-pr" then do;
			gen_type = "printer";
			call enter_output_request$default_request_type (gen_type,
			     info.queue_name, default_queue, max_queue, code);
		     end;
		     else if arg = "-punch" | arg = "-pch" then do;
			gen_type = "punch";
			call enter_output_request$default_request_type (gen_type,
			     info.queue_name, default_queue, max_queue, code);
		     end;
		     else if arg = "-plot" then do;
			gen_type = "plotter";
			call enter_output_request$default_request_type (gen_type,
			     info.queue_name, default_queue, max_queue, code);
		     end;
		     else if arg = "-forms" then do;	/* select special forms requests */
			call get_arg (i+1);		/* check for optional forms name */
			if code = 0 & index (arg, "-") ^= 1 then do;
			     i = i + 1;		/* increment arg index */
			     info.forms_name = arg;	/* and save form name */
			end;
			else info.forms_name = "";	/* else show no form name given */
			info.forms_sw = "1"b;
		     end;
		     else goto BADOPT;		/* no other arguments valid for daemon requests */
		end;
		else do;
BADOPT:		     err_msg = arg;
		     call print_err_msg (-1, error_table_$badopt);
		     return;
		end;
	     end;					/* end control argument do group */

	     else do;				/* not a control argument; might be a pathname */

		if abs_list_sw & index(arg, ">") ^= 1 then do;
						/* if abs list, it might be user name or request ID */

		     if index(arg, "abs") = 1 & verify (substr (arg, 4), "0123456789") = 0 then do; /* absN */
			if abs_n_sw then do;
			     arg_msg = "Only one absN argument allowed";
			     goto PRINT_ARG_ERR;
			end;
			if info.q_opt_sw then do;
			     arg_msg = "The -queue and absN arguments are incompatible";
			     goto PRINT_ARG_ERR;
			end;
			if info.id_sw then do;
			     arg_msg = "The request ID and absN arguments are incompatible";
			     goto PRINT_ARG_ERR;
			end;
			info.q_opt_sw = "1"b;
			start, finish = a_queue;
			info.id_sw = "1"b;
			info.request_id = request_id_ (a_request_id);
		     end;

		     else if i > 3 | ctl_arg_given then do; /* only first 2 args can be user and request ID */
FULL_PATH_REQUIRED:
			arg_msg = "Relative pathnames not allowed";
			goto PRINT_ARG_ERR;
		     end;

		     else if verify (arg, "0123456789.") = 0 then do; /* digits and dot must be request ID */
			if info.id_sw then do;
			     arg_msg = "Reqest ID given twice";
			     goto PRINT_ARG_ERR;
			end;
			info.id_sw = "1"b;
			info.request_id = arg;
		     end;
		     else if search (arg, CAPITALS) = 1 then do;
						/* if it begins with a capital,
						   assume it's a user name */
			info.user_sw = "1"b;
			info.person = before (arg, ".");
			info.project = before (after (arg, "."), ".");
			if info.person = "" then info.person = "*";
			if info.project = "" then do; /* allow operator to forget the dot between person and project */
			     call get_arg (i+1);	/* look ahead at next arg */
			     if code = 0 then do;	/* if there is one */
				if arglen <= 9	/* if it's not too long */
				& search (arg, CAPITALS) = 1 then do;
						/* and it begins with capital */
				     info.project = arg;
						/* assume it is the project name */
				     i = i + 1;	/* skip past this argument */
				end;
			     end;
			     if info.project = "" then info.project = "*"; /* if next arg wasn't it, set it to * */
			end;
			else goto FULL_PATH_REQUIRED; /* neither request ID nor user name */
		     end;
		end;
		else do;				/* pick up and store pathname */
		     if info.ename_sw then goto DUP_ENTRY_PATH;
		     call expand_pathname_ (arg, info.dirname, info.ename, code);
		     if code ^= 0 then do;
			call ioa_$rsnnl ("Expanding pathname: ^a", err_msg, rs_len, arg);
			call print_err_msg (-1, code);
			return;
		     end;
		     info.dirname_sw, info.ename_sw = "1"b;
		end;
	     end;

	end;					/* end argument loop */

/* Now check the arguments for consistency */

CHECK:

	if abs_list_sw then
	     if ^(info.immediate | info.q_opt_sw | foreground_sw | info.id_sw | info.ename_sw
	     | info.resource_sw | info.deferred_indefinitely | info.sender_sw | info.user_sw)
	     & ^info.total_sw then do;
		err_msg =
		     "No job selection arguments given. Use ""-et **"" if you really want to list all jobs in all queues";
		call print_err_msg (-1, 0);
		return;
	     end;

	if info.all_opt_sw & info.q_opt_sw then do;
	     err_msg = "The -all and -queue control arguments are incompatible.";
	     call print_err_msg (-1, 0);
	     return;
	end;

	if info.q_opt_sw then do;
	     if priority = -1 & info.request_type = ABS then;
	     else if priority < min_queue | priority > max_queue then do;
		call ioa_$rsnnl ("-queue ^d is invalid.  Use a number from ^d to ^d.", err_msg, rs_len,
		     priority, min_queue, max_queue);
		call print_err_msg (-1, 0);
		return;
	     end;
	end;

	if foreground_sw then
	     if info.all_opt_sw | info.q_opt_sw then do;
		call ioa_$rsnnl ("The following control arguments are incompatible: -foreground^[^x-all^]^[^x-queue^]",
		     err_msg, rs_len, info.all_opt_sw, info.q_opt_sw);
		call print_err_msg (-1, 0);
		return;
	     end;

	if info.long_sw & info.total_sw then do;
	     call ioa_$rsnnl ("The following control arguments are incompatible: -long^ and -total",
		err_msg, rs_len);
	     call print_err_msg (-1, 0);
	     return;
	end;
	if info.request_type = IO & info.long_sw	/* ldr -long prints contents of requests */
	& gen_type ^= "printer" & gen_type ^= "punch" & gen_type ^= "plotter" then do;
	     call ioa_ ("Warning: the -long control argument is only valid for
printer, punch or plotter generic types.");
	     info.long_sw = ""b;			/* if we don't know the structure of this generic type */
	end;					/* just list the stuff in the message header */

/* Now set first and last queue according to arguments or defaults (but -q argument processing sets them in-line) */

	if info.all_opt_sw | info.search_all then do;
	     start = min_queue;
	     finish = max_queue;
	end;
	else if foreground_sw then
	     start, finish = -1;
	else if ^info.q_opt_sw then do;		/* no queue specified - set defaults */
	     start = min_queue;			/* -search_all is the default */
	     finish = max_queue;			/* that is, search all queues */
	     info.search_all = "1"b;			/* but only print for queues that we select requests from */

	end;
	if info.request_type = ABS then do;		/* for absentee queues */
	     if start = 1 then			/* if user said -q 1 */
		start = 0;			/* we pretend queue 0 is the first part of queue 1 */
	     if start <= 0				/* if listing queue 0 */
	     & finish >= 1				/* and also queue 1 */
	     then info.abs_q_1 = "1"b;		/* turn on the "pretend they are one queue" switch */
	end;

/* Arguments are ok. Get ready to call lar_util_. First, get a temp segment for lar_util_ to build the listing in. */

	info.mseg_idx = 0;				/* no open mseg */

/* CONDITION HANDLER FOR cleanup */

	tp = null();
	on condition (cleanup) begin;			/* but first be sure we will give it back no matter what */
	     if info.mseg_idx ^= 0 then		/* if we have an open mseg */
		call message_segment_$close (info.mseg_idx, i); /* i is code, to be ignored */
	     if tp ^= null then			/* if we have a temp seg */
		call release_temp_segment_ (id, tp, code); /* give it back */
	end;					/* end begin block */

/* END CONDITION HANDLER */

	call get_temp_segment_ (id, tp, code);
	if code ^= 0 then do;
	     err_msg = "temporary segment";
	     call print_err_msg (-1, code);
	     return;
	end;

/* Initialize, before entering loop over queues */

	info.temptr = tp;

/* Beginning of loop over one or more queues */

	do info.queue = start to finish;
	     if info.queue = -1 then ent = "absentee_foreground.ms"; /* construct entry name of message segment */
	     else call ioa_$rsnnl ("^a_^d.ms", ent, rs_len, info.queue_name, info.queue);
	     call message_segment_$open (dir, ent, info.mseg_idx, code); /* initiate message segment containing requests */
	     if code = 0 then do;			/* if we opened it successfully, go list it */

/* call lar_util_, which will build up a listing of this queue's requests, in a printable segment */

		call lar_util_ (info_ptr, code);	/* get information on requests in this queue */
		call message_segment_$close (info.mseg_idx, ignore_code);
						/* close message segment */
	     end;
	     if code ^= 0 then do;
		call ioa_$rsnnl ("^[Attempting to open^x^;^]^a>^a", err_msg, rs_len, (info.mseg_idx = 0), dir, ent);
		call print_err_msg (-1, code);
	     end;
	     info.mseg_idx = 0;			/* so cleanup handler doesn't try to close it again */
	     info.input_count = info.output_count;	/* copy new length of temorary */
	end;

/* End of loop over queues. Now print the segment built by lar_util_. */

/* Under some circumstances, lar_util_ will put nothing in the segment, rather than put out lots of lines
   that say "no requests". So here we check for those circumstances, and print a line of explanation. */

	if (info.all_opt_sw & info.message_count = 0 & ^info.no_total_sw) /* if -all and Qs were all empty */
	| (info.search_all & info.select_count = 0) then do; /* or -search_all and no requests were selected */

/* We want to say one of:
   There are 		}
   You have 		} no requests in any ^a queue.
   ^a.^a has 		}
   Selection arguments matched}

   Figure out which. */

	     if info.message_count = 0 then
		i = 1;				/* There are no requests in ... */
	     else if info.user_select_count = 0 then
		if ^info.user_sw then		/* if user name not given */
		     i = 2;			/* You have no requests in ... */
		else i = 3;			/* ^a.^a has no requests in ... */
	     else i = 4;				/* Selection arguments matched no requests in ... */

/* Now say it */

	     call ioa_ (
		"^[^2sThere are^;^2sYou have^;^a.^a has^;^2sSelection arguments matched^] no requests in any ^a queue.",
		i, info.person, info.project, info.queue_name);

	end;

/* If we printed the above message, there should be nothing in the segment except an initial newline.
   If there is something else, we have a bug. Print it, so the bug will be obvious. */

	if info.output_count > 1 then do;
	     call iox_$put_chars (iox_$user_output, info.temptr, info.output_count, code);
	     if code ^= 0 then do;
		err_msg = "user_output";
		call print_err_msg (-1, code);
	     end;
	     if (info.all_opt_sw | info.search_all) & info.total_sw then
		call ioa_;			/* put blank line after single-spaced totals lines */
	end;

/* This is the main exit from this procedure */

	call release_temp_segment_ (id, tp, code);
ERROR_EXIT:
	return;



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	ADDITIONAL       ENTRY  	 POINTS					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


test_lar:	entry (sys_dir);				/* entry point for testing lar command		*/

    dcl	sys_dir			char(*);

	not_initialized = "1"b;			/* get queue data again			*/
	abs_dir = sys_dir;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


test_ldr:	entry (sys_dir);

	not_initialized = "1"b;			/* get queue data again			*/
	iod_dir = sys_dir;
	call iod_info_$test (sys_dir);
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


test_lrr:	entry (sys_dir);

	not_initialized = "1"b;			/* get queue data again			*/
	retriever_dir = sys_dir;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	INTERNAL	 PROCEDURES						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


get_arg:	proc (argno);

    dcl	argno			fixed bin;

	     if abs_list_sw then
		call cu_$arg_ptr_rel (argno, argptr, arglen, code, a_arglist_ptr);
	     else call cu_$arg_ptr (argno, argptr, arglen, code);
	     return;

	end get_arg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


init:	proc;

	     if not_initialized then do;
		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;
		call system_info_$default_absentee_queue (abs_default_q);
		     if abs_default_q = 0 then abs_default_q = 3;

		call hcs_$star_ (retriever_dir, "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 */
	     end;

	     info_ptr = addr (local_info);
	     unspec (info) = ""b;			/* zero everyting in info structure */

	     if abs_list_sw then do;			/* if abs list command */
		nargs = a_arg_count;		/* pick up length of admin$abs's arglist */
		i = 2;				/* skip first arg, which is "list" */
		info.admin_sw = "1"b;		/* always list other users' requests */
	     end;
	     else do;				/* user command */
		call cu_$arg_count(nargs, code);	/* get length of this procedure's arglist */
		if code ^= 0 then do;
		     call com_err_ (code, id);
		     go to ERROR_EXIT;
		end;
		i = 1;				/* and start with the first one */
	     end;

	     return;

	end init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


print_err_msg: proc (sv, ec);

    dcl	sv			fixed bin,	/* severity, for use in sys_log_ calls */
	ec			fixed bin(35);	/* error code */

/* The global variable, err_msg, is an implicit argument */

	     if abs_list_sw then do;
		if ec ^= 0 then
		     call sys_log_$command_error (sv, ec, "abs list", "^a", err_msg);
		else call sys_log_$command (sv, "abs list: ^a", err_msg);
	     end;
	     else call com_err_ (ec, id, "^a", err_msg);
	     return;

	end print_err_msg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


     end list_abs_requests;




		    match_request_id_.pl1           11/04/82  1945.8rew 11/04/82  1624.7       39249



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


match_request_id_:
     procedure (msg_time, id_arg) returns (bit aligned);

/* This procedure provides request ID displaying and matching for absentee and I/O daemon requests.

   dcl match_request_id_ entry (fixed bin (71), char (*)) returns (bit (1) aligned);
   if match_request_id_ (request.msg_time, ID_arg) then ... ;

   A long request ID is a 19-character string, displaying the time the request was entered, in
   the form YYMMDDhhmmss.ffffff - that is, the year, month, day, hour, minute, second,
   and 6-digit fractional second. In most cases, the 6 digits to the left of the decimal point
   (hhmmss) will be enough to uniquely identify a request from among all other requests in the system.
   Those 6 digits are displayed by default by the request entering and listing commands. Display of
   the full 19 digits can be requested by using the -long_id control argument.

   The user, when identifying a request with the -id ID argument pair, may give any number of
   digits. The match_request_id_ entry point of this procedure matches such a substring against
   (the display form of) a message time, and returns true ("1"b) if it matches, and false (""b) if it doesn't.
   The user-supplied substring is oriented within the 19 digit field by means of the decimal point
   (with one being assumed to the right of the last digit if none is given). If the corresponding
   substrings match, the IDs are said to match. It is the responsibility of the caller to search the
   entire set of requests that are selected (by other arguments or by default) and take appropriate action
   if the user-supplied ID matches more than one request (e.g., select all of them for listing,
   but select none for cancelling, and ask for a longer ID).

   Although some of the digits in a request ID have a limited range (e.g., MM must be 01-12), and of
   course the ID can contain only decimal digits and at most one decimal point, and so some validity checking could
   be performed on an ID, it is considered not worthwhile, and is not done by this procedure. Callers could,
   if they wish, verify that the string contains only decimal digits and a decimal point, but that
   is probably not worthwhile either. Most user typing errors will consist of incorrect or transposed
   digits, not detectable by any error checking.

   Initial coding by T. Casey, May 1978
   Modified April 1979 by T. Casey for MR7.0a to fix minor bugs.
   Modified February 1980 by C. Hornig to remove request_id_
   /*

   /* DECLARATIONS */
/* Input arguments */

dcl msg_time fixed bin (71);				/* first argument to both entry points */
dcl id_arg char (*);				/* second argument to match_... entry point */

/* Misc. automatic variables */

dcl (dp, l) fixed bin;				/* char counters, for matching */
dcl id char (19);					/* display form of msg_time, for returning or matching */
dcl vid char (20) varying;				/* copy of id_arg, with leading and trailing blanks removed */

/* Other stuff */

dcl request_id_ entry (fixed bin (71)) returns (char (19));

dcl (index, length, ltrim, rtrim, substr) builtin;	/* for matching */

/* PROCEDURE */

	id = request_id_ (msg_time);
	vid = rtrim (ltrim (id_arg));			/* strip off leading and trailing blanks and get length of result */
	l = length (vid);				/* l is easier to type */
	if l > 19
	then					/* this is why vid is char (20) varying */
	     return ("0"b);				/* string too long - could not possibly match */
	dp = index (vid, ".");			/* look for decimal point */
	if dp = 0
	then					/* if none */
	     dp = l + 1;				/* pretend there's one after the last digit */
	if dp > 13 then return ("0"b);		/* too many digits to left of decimal point */
	if l - dp > 6 then return ("0"b);		/* too many to right of it */
	if substr (id, 14 - dp, l) = vid
	then return ("1"b);
	else return ("0"b);

     end match_request_id_;




		    pl1_abs.pl1                     10/06/88  1031.2rew 10/06/88  1029.0      276867



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(88-09-20,TLNguyen), approve(88-09-20,MCR7984),
     audit(88-10-03,Parisek), install(88-10-06,MR12.2-1133):
     Make the fortran_abs command accept the -card fortran compiler control
     argument.
                                                   END HISTORY COMMENTS */


/* This program sets up absentee jobs to do pl1, fortran, cobol, alm, algol68, and pascal compilations.

   Initially coded in Nov 1971 by Dennis Capps
   Modified April 5, 1972 by Dennis Capps
   Modified for use with Version II PL/I Sept 25, 1972 by Robert S. Coren
   Modified 6/20/74 by Steve Herbst to accept all dprint and compiler options
   Modified 9/20/76 by R.J.C. Kissel to accept the -profile control argument
   Modified 761227 by PG to remove v1pl1_abs, v2pl1_abs, and switch to expand_pathname_
   Modified  7/12/78 by James R. Davis to add cobol
   Modified 8/10/78 by Paul E. Smee to update options for fortran and pl1.
   Modified 9/27/78 By JRD for level and no source and extend, (COBOL)
   Modified 12/27/78 by Paul E. Smee to update fortran options for FORTRAN 5.
   Modified 10/10/79 by Paul E. Smee to update options for MR8.0.
   Modified 4 April 1980 by M. N. Davidoff to for pl1 -source, -symbols and to make -brief_table work.
   Modified 23 September 1980 by G. Palter to allow absentee queue 4, add new Fortran control arguments, add "-ind" for
      "-indent", use the site-settable default absentee queue as the default queue, and use the highest numbered dprint
      queue when there is no dprint queue corresponding to the absentee queue.
   Modified 14 October 1980 by G. Palter to add negative control arguments for PL/I and "-no_table" for PL/I, Fortran, and
      COBOL.
   Modified 20 May 1981 by EBush to add "-nsb" and "-target" to ALM.
   Modified 2 Feb 1982 by Richard Wendland (SWURCC, Bath University, England) to handle Algol 68.
   Modified 5 Dec 1983 by C Spitzer. add MR10.2 fortran control arguments.
   Modified 18 Oct 1983 by S. Herbst to add pascal_abs (psa)
*/

/* format: style3,ll122 */

pl1_abs:
pa:
     procedure options (variable);

/* automatic */

dcl	abs_args_list_len	fixed bin (21);
dcl	abs_args_list_ptr	pointer;
dcl	abs_args_list_space char (256) varying;
dcl	absentee_queue	char (1);
dcl	absentee_queue_n	fixed bin;		/* default absentee queue */
dcl	alm_arguments_collection
			bit (1) aligned;		/* collecting arguments to the assembly */
dcl	areap		ptr;
dcl	argcount		fixed bin;
dcl	arglen		fixed bin (21);
dcl	argno		fixed bin;
dcl	argp		ptr;
dcl	argu_auto		char (24);
dcl	checkdir		char (168);
dcl	checkent		char (32);
dcl	code		fixed bin (35);
dcl	curarg		char (32);
dcl	default_absentee_queue
			bit (1) aligned;
dcl	dp_args_list_len	fixed bin (21);
dcl	dp_args_list_ptr	pointer;
dcl	dp_args_list_space	char (256) varying;
dcl	dprint_queue	char (1);
dcl	error_sw		bit (1) aligned;
dcl	first_entryname	char (32);
dcl	function		char (7);
dcl	function_abs	char (32);
dcl	hold		char (6) varying;
dcl	i		fixed bin;
dcl	1 lang,					/* must init here because of multiple entries */
	  2 algol68	bit (1) initial ("0"b),
	  2 alm		bit (1) initial ("0"b),
	  2 cobol		bit (1) initial ("0"b),
	  2 fortran	bit (1) initial ("0"b),
	  2 pl1		bit (1) initial ("0"b),
	  2 pascal	bit (1) initial ("0"b);
dcl	limit_no		pic "(9)z9";
dcl	limit_sw		bit (1) aligned;
dcl	no_of_copies_str	char (1);
dcl	out_file		char (168);
dcl	outsw		bit (1) aligned;
dcl	request_type	char (32);
dcl	1 saw,
	  2 optimize	bit (1),
	  2 safe_ot	bit (1),
	  2 full_ot	bit (1),
	  2 subscriptrange	bit (1),
	  2 stringrange	bit (1),
	  2 card		bit (1),
	  2 ln		bit (1),
	  2 ansi66	bit (1),
	  2 ansi77	bit (1),
	  2 quote		bit (1),
	  2 point		bit (1);
dcl	segname_list_len	fixed bin (21);
dcl	segname_list_ptr	pointer;
dcl	segname_list_space	char (256) varying;
dcl	temp		fixed bin (35);

/* based */

dcl	abs_args_list	char (abs_args_list_len) varying based (abs_args_list_ptr);
dcl	argu		char (arglen) based (argp);
dcl	digit_pic		pic "9" based;
dcl	dp_args_list	char (dp_args_list_len) varying based (dp_args_list_ptr);
dcl	segname_list	char (segname_list_len) varying based (segname_list_ptr);
dcl	system_area	area based (areap);

/* builtin */

dcl	(addr, binary, codeptr, convert, hbound, index, lbound, length,
	 ltrim, max, maxlength, rtrim, string)
			builtin;

/* condition */

dcl	cleanup		condition;

/* internal static */

dcl	SP		char (1) internal static options (constant) initial (" ");
dcl	opt_table		(29) char (12) internal static options (constant)
			initial ("-list", "-ls", "-map", "-brief", "-bf", "-check", "-ck", "-table", "-tb",
			"-brief_table", "-bftb", "-time", "-tm", "-debug", "-db", "-optimize", "-ot", "-profile",
			"-pf", "-severity1", "-severity2", "-severity3", "-severity4", "-sv1", "-sv2", "-sv3",
			"-sv4", "-no_table", "-ntb");

/* external static */

dcl	error_table_$noarg  fixed bin (35) external static;
dcl	error_table_$badopt fixed bin (35) external static;
dcl	error_table_$inconsistent
			fixed bin (35) external static;

/* entry */

dcl	absolute_pathname_	entry (char (*), char (*), fixed bin (35));
dcl	com_err_		entry options (variable);
dcl	com_err_$suppress_name
			entry options (variable);
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	cv_dec_check_	entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl	cv_oct_check_	entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl	enter_abs_request	entry options (variable);
dcl	expand_pathname_$add_suffix
			entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl	get_system_free_area_
			entry returns (ptr);
dcl	get_wdir_		entry returns (char (168) aligned);
dcl	hcs_$fs_get_path_name
			entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl	hcs_$status_minf	entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl	ioa_		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	requote_string_	entry (char (*)) returns (char (*));
dcl	suffixed_name_$new_suffix
			entry (char (*), char (*), char (*), char (32), fixed bin (35));
dcl	system_info_$default_absentee_queue
			entry (fixed bin);
dcl	system_type_	entry (char (*), char (*), fixed bin (17), fixed bin (35));

/* format: inddcls */
%page;
/* program */

	lang.pl1 = "1"b;
	function = "pl1";
	function_abs = "pl1_abs";
	goto START;

alm_abs:
aa:
     entry options (variable);

	lang.alm = "1"b;
	function = "alm";
	function_abs = "alm_abs";
	goto START;

fortran_abs:
fa:
     entry options (variable);

	lang.fortran = "1"b;
	function = "fortran";
	function_abs = "fortran_abs";
	goto START;

cobol_abs:
cba:
     entry options (variable);

	lang.cobol = "1"b;
	function = "cobol";
	function_abs = "cobol_abs";
	goto START;

algol68_abs:
a68a:
     entry options (variable);

	lang.algol68 = "1"b;
	function = "algol68";
	function_abs = "algol68_abs";
	goto START;

pascal_abs:
psa:
     entry options (variable);

	lang.pascal = "1"b;
	function = "pascal";
	function_abs = "pascal_abs";
	goto START;

START:
	areap = get_system_free_area_ ();

	abs_args_list_space = "";
	abs_args_list_ptr = addr (abs_args_list_space);
	abs_args_list_len = maxlength (abs_args_list_space);

	alm_arguments_collection = "0"b;
	default_absentee_queue = "1"b;

	dp_args_list_space = "";
	dp_args_list_ptr = addr (dp_args_list_space);
	dp_args_list_len = maxlength (dp_args_list_space);

	error_sw = "0"b;
	hold = "dprint";				/* dprint listing when done */
	limit_sw = "0"b;				/* no absentee timer limit */
	no_of_copies_str = "1";
	outsw = "0"b;				/* -output_file not used */
	request_type = "printer";

	segname_list_space = "";
	segname_list_ptr = addr (segname_list_space);
	segname_list_len = maxlength (segname_list_space);

	call system_info_$default_absentee_queue (absentee_queue_n);
	if absentee_queue_n = 0
	then absentee_queue_n = 3;			/* default default absentee queue */
	absentee_queue = convert (digit_pic, absentee_queue_n);
	dprint_queue = absentee_queue;

	call cu_$arg_count (argcount, code);
	if code ^= 0
	then do;
		call com_err_ (code, function_abs);
		return;
	     end;

	if argcount = 0
	then do;
		call com_err_$suppress_name (0, function_abs, "Usage: ^a paths {^a_args} {dp_args} {-control_args}",
		     function_abs, function);
		return;
	     end;

	on cleanup call cleaner_up ();


/* Start looking at arguments */

	string (saw) = ""b;

	do argno = 1 to argcount;			/* Loop ends at ENDLOOP */
	     call cu_$arg_ptr (argno, argp, arglen, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, function_abs, "Argument ^d.", argno);
		     goto REQUEST_NOT_SUBMITTED;
		end;

	     curarg = argu;

	     if alm_arguments_collection
	     then do;				/* add this argument without interpretation */
		     call add_requoted (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
		     goto ENDLOOP;
		end;

	     else if index (argu, "-") ^= 1
	     then begin;
		     dcl	     bitcnt	     fixed bin (24);
		     dcl	     type		     fixed bin (2);

		     call expand_pathname_$add_suffix (argu, function, checkdir, checkent, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, function_abs, "^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     call hcs_$status_minf (checkdir, checkent, 1, type, bitcnt, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, function_abs, "^a>^a", checkdir, checkent);
			     error_sw = "1"b;
			end;

		     if segname_list = ""
		     then first_entryname = checkent;

		     call add_requoted (argu, segname_list_ptr, segname_list_len, addr (segname_list_space));
		     goto ENDLOOP;
		end;

/* Check for absentee control arguments */

	     else if argu = "-hold" | argu = "-hd"
	     then do;
		     hold = "hold";
		     goto ENDLOOP;
		end;

	     else if argu = "-limit" | argu = "-li"
	     then do;
		     limit_sw = "1"b;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code ^= 0 | temp <= 0
		     then do;
			     call com_err_ (0, function_abs, "Invalid limit. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     limit_no = temp;
		     goto ENDLOOP;
		end;

	     else if argu = "-queue" | argu = "-q"
	     then do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code = 0 & 1 <= temp & temp <= 4
		     then absentee_queue = convert (digit_pic, temp);
		     else do;
			     call com_err_ (0, function_abs, "Invalid queue number. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     default_absentee_queue = "0"b;
		     dprint_queue = absentee_queue;
		     goto ENDLOOP;
		end;

	     else if argu = "-output_file" | argu = "-of"
	     then do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     call absolute_pathname_ (argu, out_file, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, function_abs, "^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     outsw = "1"b;
		     goto ENDLOOP;
		end;

/* Is this a dprint option? */

	     else if argu = "-notify" | argu = "-nt" | argu = "-single" | argu = "-sg" | argu = "-no_endpage"
		     | argu = "-nep" | argu = "-non_edited" | argu = "-ned" | argu = "-access_label"
		     | argu = "-albl" | argu = "-truncate" | argu = "-tc" | argu = "-no_label" | argu = "-nlbl"
	     then do;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-destination" | argu = "-ds" | argu = "-header" | argu = "-he" | argu = "-label"
		     | argu = "-lbl" | argu = "-top_label" | argu = "-tlbl" | argu = "-bottom_label" | argu = "-blbl"
	     then do;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     call add_requoted (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-request_type" | argu = "-rqt"
	     then begin;
		     dcl	     gen_type	     char (32);

		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     call iod_info_$generic_type (argu, gen_type, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, function_abs, "Request type ^a.", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     if gen_type ^= "printer"
		     then do;
			     call com_err_ (0, function_abs, "Request type ^a is not for the printer.", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     request_type = argu;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-line_length" | argu = "-ll"
	     then do;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code ^= 0 | temp < 2 | temp > 136
		     then do;
			     call com_err_ (0, function_abs, "Invalid line length. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-page_length" | argu = "-pl"
	     then do;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code ^= 0 | temp < 2 | temp > 66
		     then do;
			     call com_err_ (0, function_abs, "Invalid page length. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-indent" | argu = "-ind" | argu = "-in"
	     then do;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code ^= 0 | temp < 1 | temp > 136
		     then do;
			     call com_err_ (0, function_abs, "Invalid indentation. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-copy" | argu = "-cp"
	     then do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code = 0 & 1 <= temp & temp <= 4
		     then no_of_copies_str = convert (digit_pic, temp);
		     else do;
			     call ioa_ (0, function_abs, "Invalid number of copies. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     goto ENDLOOP;
		end;

/* Check for compiler control arguments */

	     else if lang.pl1
	     then if argu = "-check_ansi" | argu = "-separate_static" | argu = "-ss" | argu = "-source" | argu = "-sc"
		     | argu = "-symbols" | argu = "-sb" | argu = "-single_symbol_list" | argu = "-ssl"
		     | argu = "-long_profile" | argu = "-lpf" | argu = "-long" | argu = "-lg" | argu = "-no_check"
		     | argu = "-nck" | argu = "-no_check_ansi" | argu = "-no_list" | argu = "-nls"
		     | argu = "-no_optimize" | argu = "-not" | argu = "-no_profile" | argu = "-npf"
		     | argu = "-no_separate_static" | argu = "-nss" | argu = "-no_debug" | argu = "-ndb"
		     | argu = "-no_time" | argu = "-ntm"
		then goto FOUND_IT;
		else if argu = "-prefix"
		then do;
			call add (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
			argno = argno + 1;
			call cu_$arg_ptr (argno, argp, arglen, code);
			if code ^= 0
			then goto TOO_FEW_ARGS;

			call add_requoted (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
			goto ENDLOOP;
		     end;
		else ;

	     else if lang.fortran
	     then if argu = "-fold" | argu = "-round" | argu = "-truncate" | argu = "-relocatable" | argu = "-rlc"
		     | argu = "-time_ot" | argu = "-non_relocatable" | argu = "-nrlc" | argu = "-auto"
		     | argu = "-auto_zero" | argu = "-check_multiply" | argu = "-ckmpy" | argu = "-default_full"
		     | argu = "-dff" | argu = "-default_safe" | argu = "-dfs" | argu = "-free"
		     | argu = "-large_array" | argu = "-la" | argu = "-long" | argu = "-lg" | argu = "-long_profile"
		     | argu = "-lpf" | argu = "-no_auto_zero" | argu = "-no_check" | argu = "-nck"
		     | argu = "-no_check_multiply" | argu = "-nckmpy" | argu = "-no_fold" | argu = "-no_large_array"
		     | argu = "-nla" | argu = "-no_map" | argu = "-no_version" | argu = "-no_very_large_array"
		     | argu = "-nvla" | argu = "-no_vla_parm" | argu = "-static" | argu = "-version"
		     | argu = "-very_large_array" | argu = "-vla" | argu = "-vla_parm" | argu = "-top_down"
		then goto FOUND_IT;
		else if argu = "-ansi66"
		then do;
			saw.ansi66 = "1"b;
			goto FOUND_IT;
		     end;
		else if argu = "-ansi77"
		then do;
			saw.ansi77 = "1"b;
			goto FOUND_IT;
		     end;
		else if argu = "-card"
		then do;
			saw.card = "1"b;
			goto FOUND_IT;
		     end;
		else if argu = "-line_numbers" | argu = "-ln"
		then do;
			saw.ln = "1"b;
			goto FOUND_IT;
		     end;
		else if argu = "-no_line_numbers" | argu = "-nln"
		then do;
			saw.ln = "0"b;
			goto FOUND_IT;
		     end;
		else if argu = "-optimize" | argu = "-ot"
		then do;
			saw.optimize = "1"b;
			goto FOUND_IT;
		     end;
		else if argu = "-safe_optimize" | argu = "-safe_ot"
		then do;
			saw.safe_ot = "1"b;
			goto FOUND_IT;
		     end;
		else if argu = "-full_optimize" | argu = "-full_ot"
		then do;
			saw.full_ot = "1"b;
			goto FOUND_IT;
		     end;
		else if argu = "-no_optimize" | argu = "-not"
		then do;
			saw.optimize, saw.safe_ot, saw.full_ot = "0"b;
			goto FOUND_IT;
		     end;
		else if argu = "-subscriptrange" | argu = "-subrg"
		then do;
			saw.subscriptrange = "1"b;
			goto FOUND_IT;
		     end;
		else if argu = "-no_subscriptrange" | argu = "-nsubrg"
		then do;
			saw.subscriptrange = "0"b;
			goto FOUND_IT;
		     end;
		else if argu = "-stringrange" | argu = "-strg"
		then do;
			saw.stringrange = "1"b;
			goto FOUND_IT;
		     end;
		else if argu = "-no_stringrange" | argu = "-nstrg"
		then do;
			saw.stringrange = "0"b;
			goto FOUND_IT;
		     end;
		else ;

	     else if lang.alm
	     then if argu = "-list" | argu = "-ls" | argu = "-no_symbols" | argu = "-nsb" | argu = "-brief"
		     | argu = "-bf"
		then goto FOUND_IT;
		else if argu = "-target" | argu = "-tgt"
		then do;
			call add (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
			argno = argno + 1;
			call cu_$arg_ptr (argno, argp, arglen, code);
			if code ^= 0
			then goto TOO_FEW_ARGS;

			argu_auto = argu;
			call system_type_ (argu_auto, (""), (0), code);
			if code ^= 0
			then do;
				call com_err_ (code, function_abs, argu);
				goto REQUEST_NOT_SUBMITTED;
			     end;
			else do;
				call add (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
				goto ENDLOOP;
			     end;
		     end;
		else if argu = "-arguments" | argu = "-ag"
		then do;
			alm_arguments_collection = "1"b;
			goto FOUND_IT;
		     end;
		else goto UNREC_OPT;

	     else if lang.cobol
	     then if argu = "-format" | argu = "-fmt" | argu = "-runtime_check" | argu = "-rck" | argu = "-level1"
		     | argu = "-lev1" | argu = "-level2" | argu = "-lev2" | argu = "-level3" | argu = "-lev3"
		     | argu = "-level4" | argu = "-lev4" | argu = "-level5" | argu = "-lev5" | argu = "-expand"
		     | argu = "-exp"
		then goto FOUND_IT;
		else if argu = "-brief_table" | argu = "-bftb" | argu = "-optimize" | argu = "-ot"
		then goto UNREC_OPT;		/* cobol lacks these */
		else if argu = "-temp_dir" | argu = "-td"
		then do;
			call add (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
			argno = argno + 1;
			call cu_$arg_ptr (argno, argp, arglen, code);
			if code ^= 0
			then goto TOO_FEW_ARGS;

			call absolute_pathname_ (argu, "", code);
			if code ^= 0
			then do;
				call com_err_ (code, function_abs, "^a", argu);
				goto REQUEST_NOT_SUBMITTED;
			     end;

			call add_requoted (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
			goto ENDLOOP;
		     end;
		     else;

		else if lang.algol68
		then if argu = "-severity0" | argu = "-sv0" | argu = "no_out_check" | argu = "-nock"
			| argu = "-source" | argu = "-sc" | argu = "-no_list" | argu = "-nls" | argu = "no_check"
			| argu = "-nck"
		     then goto FOUND_IT;
		     else if argu = "-brief" | argu = "-bf" | argu = "-optimize" | argu = "-ot" | argu = "-time"
			     | argu = "-tm" | argu = "-profile" | argu = "-pf"
		     then goto UNREC_OPT;
		     else if argu = "-card"
		     then do;
			     saw.card = "1"b;
			     goto FOUND_IT;
			end;
		     else if argu = "-quote"
		     then do;
			     saw.quote = "1"b;
			     goto FOUND_IT;
			end;
		     else if argu = "-point"
		     then do;
			     saw.point = "1"b;
			     goto FOUND_IT;
			end;
		     else if argu = "-debug" | argu = "-db"
		     then do;
			     call add (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
			     argno = argno + 1;
			     call cu_$arg_ptr (argno, argp, arglen, code);
			     if code ^= 0
			     then goto TOO_FEW_ARGS;

			     temp = cv_oct_check_ (argu, code);
			     if code ^= 0
			     then do;
				     call com_err_ (0, function_abs,
					"Invalid octal number ^a supplied for -debug.", argu);
				     goto REQUEST_NOT_SUBMITTED;
				end;

			     goto FOUND_IT;
			end;
			else;

		else if lang.pascal
		then if argu = "-add_exportable_names" | argu = "-aen" | argu = "-brief_map" | argu = "-bfm"
			| argu = "-conditional_execution" | argu = "-cond" | argu = "-english"
			| argu = "-error_messages" | argu = "-em" | argu = "-french"
			| argu = "-full_extensions" | argu = "-full" | argu = "-interactive" | argu = "-int"
			| argu = "-io_warnings" | argu = "-iow" | argu = "-long_profile" | argu = "-lpf"
			| argu = "-no_debug" | argu = "-ndb" | argu = "-no_error_messages" | argu = "-nem"
			| argu = "-no_interactive" | argu = "-nint" | argu = "-no_io_warnings" | argu = "-niow"
			| argu = "-no_list" | argu = "-no_long_profile" | argu = "-nlpf"
			| argu = "-no_private_storage" | argu = "-nps" | argu = "-no_profile" | argu = "-npf"
			| argu = "-no_relocatable" | argu = "-nonrelocatable" | argu = "-nrlc"
			| argu = "-no_standard" | argu = "-nonstandard" | argu = "-ns"
			| argu = "-private_storage" | argu = "-ps" | argu = "-relocatable" | argu = "-rlc"
			| argu = "-sol_extensions" | argu = "-sol" | argu = "-standard"
		     then goto FOUND_IT;
		     else;


	     do i = lbound (opt_table, 1) to hbound (opt_table, 1) while (argu ^= opt_table (i));
	     end;

	     if i > hbound (opt_table, 1)
	     then goto UNREC_OPT;

FOUND_IT:
	     call add (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));

ENDLOOP:
	end;

	if saw.optimize & saw.safe_ot
	then do;
		call com_err_ (error_table_$inconsistent, function_abs, "-optimize and -safe_optimize");
		error_sw = "1"b;			/* keep issuing messages */
	     end;

	if saw.optimize & saw.full_ot
	then do;
		call com_err_ (error_table_$inconsistent, function_abs, "-optimize and -full_optimize");
		error_sw = "1"b;
	     end;

	if saw.full_ot & saw.safe_ot
	then do;
		call com_err_ (error_table_$inconsistent, function_abs, "-full_ot and -safe_ot");
		error_sw = "1"b;
	     end;

	if saw.full_ot & saw.subscriptrange
	then do;
		call com_err_ (error_table_$inconsistent, function_abs, "-full_ot and -subscriptrange");
		error_sw = "1"b;
	     end;

	if (saw.optimize & saw.subscriptrange) | (saw.safe_ot & saw.subscriptrange)
	then do;
		call com_err_ (error_table_$inconsistent, function_abs,
		     "^[-optimize^;-safe_optimize^] and -subscriptrange", saw.optimize);
		error_sw = "1"b;
	     end;

	if (saw.optimize & saw.stringrange) | (saw.safe_ot & saw.stringrange)
	then do;
		call com_err_ (error_table_$inconsistent, function_abs,
		     "^[-optimize^;-safe_optimize^] and -stringrange", saw.optimize);
		error_sw = "1"b;
	     end;

	if saw.ansi66 & saw.ansi77
	then do;
		call com_err_ (error_table_$inconsistent, function_abs, "-ansi66 and -ansi77");
		error_sw = "1"b;
	     end;

	if saw.card & saw.ln
	then do;
		call com_err_ (error_table_$inconsistent, function_abs, "-card and -line_numbers");
		error_sw = "1"b;
	     end;

	if saw.quote & saw.point
	then do;
		call com_err_ (error_table_$inconsistent, function_abs, "Only one form of stropping allowed.");
		error_sw = "1"b;
	     end;

	if saw.card & ^(saw.quote | saw.point) & lang.algol68
	then do;
		call com_err_ (error_table_$noarg, function_abs, "-card cannot be used without stropping.");
		error_sw = "1"b;
	     end;

	if error_sw
	then goto REQUEST_NOT_SUBMITTED;

	if segname_list = ""
	then do;
		call com_err_ (0, function_abs, "No segments to compile.");
		goto REQUEST_NOT_SUBMITTED;
	     end;

	if ^outsw
	then do;
		call suffixed_name_$new_suffix (first_entryname, function, "absout", checkent, code);
		if code ^= 0
		then do;
			call com_err_ (code, function_abs, "^a with absout suffix.", first_entryname);
			goto REQUEST_NOT_SUBMITTED;
		     end;

		out_file = checkent;
	     end;

	begin;
	     dcl	     default_queue	     fixed bin;
	     dcl	     max_queue	     fixed bin;

	     call iod_info_$queue_data (request_type, default_queue, max_queue, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, function_abs, "Request type ^a.", request_type);
		     goto REQUEST_NOT_SUBMITTED;
		end;

	     if default_absentee_queue		/* user didn't specify queue: use default without warnings */
	     then dprint_queue = convert (digit_pic, default_queue);

	     if binary (dprint_queue, 17) < 1 | max_queue < binary (dprint_queue, 17)
	     then do;
		     call com_err_ (0, function_abs,
			"Request type ^a does not have queue ^a. Dprint queue ^d assumed.", request_type,
			dprint_queue, max_queue);
		     dprint_queue = convert (digit_pic, max_queue);
		end;
	end;

	call hcs_$fs_get_path_name (codeptr (pl1_abs), checkdir, i, checkent, code);

	if limit_sw
	then call enter_abs_request (rtrim (checkdir) || ">translator_absin", "-queue", absentee_queue, "-restart",
		"-output_file", rtrim (out_file), "-limit", ltrim (limit_no), "-arguments", rtrim (get_wdir_ ()),
		rtrim (function), dprint_queue, (hold), no_of_copies_str, ltrim (segname_list), ltrim (abs_args_list),
		ltrim (dp_args_list));

	else call enter_abs_request (rtrim (checkdir) || ">translator_absin", "-queue", absentee_queue, "-restart",
		"-output_file", rtrim (out_file), "-arguments", rtrim (get_wdir_ ()), rtrim (function), dprint_queue,
		(hold), no_of_copies_str, ltrim (segname_list), ltrim (abs_args_list), ltrim (dp_args_list));

	call cleaner_up;

	return;


TOO_FEW_ARGS:
	call com_err_ (code, function_abs, "After ^a.", curarg);
	goto REQUEST_NOT_SUBMITTED;

UNREC_OPT:
	call com_err_ (error_table_$badopt, function_abs, "^a", argu);
	goto REQUEST_NOT_SUBMITTED;

REQUEST_NOT_SUBMITTED:
	call com_err_ (0, function_abs, "Absentee request not submitted.");
	call cleaner_up;

	return;
%page;
/* format: ^inddcls */

/* Add the argument to one of the arbitrarily lengthed output strings */

add:
     procedure (argument, output_ptr, output_len, output_space);

dcl	argument		character (*) parameter;
dcl	output_ptr	pointer parameter;
dcl	output_len	fixed binary (21) parameter;
dcl	output_space	pointer parameter;
dcl	requote_argument	bit (1) aligned;
dcl	new_min_maxlength	fixed binary (21);
dcl	old_output_len	fixed binary (21);
dcl	old_output_ptr	pointer;
dcl	output_string	character (output_len) varying based (output_ptr);
dcl	old_output_string	character (old_output_len) varying based (old_output_ptr);

	requote_argument = "0"b;
	goto START_ADDITION;

add_requoted:
     entry (argument, output_ptr, output_len, output_space);

	requote_argument = "1"b;

START_ADDITION:
	new_min_maxlength = length (output_string) + length (SP) + length (argument);
	if requote_argument				/* room for possible requoting */
	then new_min_maxlength = new_min_maxlength + length (argument) + 2;

	if new_min_maxlength > output_len
	then do;					/* need to make more space */
		old_output_ptr = output_ptr;
		old_output_len = output_len;
		output_len = max (2 * output_len, new_min_maxlength);
		allocate output_string in (system_area) set (output_ptr);
		output_string = old_output_string;
		if old_output_ptr ^= output_space
		then free old_output_string in (system_area);
	     end;

	output_string = output_string || SP;

	if requote_argument
	then output_string = output_string || requote_string_ (argument);
	else output_string = output_string || argument;

	return;

     end add;



cleaner_up:
     procedure;

	if abs_args_list_ptr ^= addr (abs_args_list_space)
	then free abs_args_list in (system_area);
	if dp_args_list_ptr ^= addr (dp_args_list_space)
	then free dp_args_list in (system_area);
	if segname_list_ptr ^= addr (segname_list_space)
	then free segname_list in (system_area);

	return;

     end cleaner_up;

     end pl1_abs;




		    runoff_abs.pl1                  11/04/82  1945.8rew 11/04/82  1624.8      158760



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* This program sets up an absentee job to format segments using runoff */

/* Initially coded: May 1972 by Sze-Ping Kuo */
/* Modified: 22 July 1975 by S. Herbst to accept new dprint control arguments */
/* Rewritten: 24 September 1980 by G. Palter based upon pl1_abs as many changes needed to be retrofitted */

/* format: style3,ll122 */

runoff_abs:
rfa:
     procedure options (variable);

/* automatic */

dcl	abs_args_list_len	fixed bin (21);
dcl	abs_args_list_ptr	pointer;
dcl	abs_args_list_space char (256) varying;
dcl	absentee_queue	char (1);
dcl	absentee_queue_n	fixed bin;		/* default absentee queue */
dcl	areap		ptr;
dcl	argcount		fixed bin;
dcl	arglen		fixed bin (21);
dcl	argno		fixed bin;
dcl	argp		ptr;
dcl	checkdir		char (168);
dcl	checkent		char (32);
dcl	code		fixed bin (35);
dcl	curarg		char (32);
dcl	default_absentee_queue
			bit (1) aligned;
dcl	dp_args_list_len	fixed bin (21);
dcl	dp_args_list_ptr	pointer;
dcl	dp_args_list_space	char (256) varying;
dcl	dprint_queue	char (1);
dcl	error_sw		bit (1) aligned;
dcl	first_entryname	char (32);
dcl	hold		char (6) varying;
dcl	i		fixed bin;
dcl	limit_no		pic "(9)z9";
dcl	limit_sw		bit (1) aligned;
dcl	no_of_copies_str	char (1);
dcl	out_file		char (168);
dcl	outsw		bit (1) aligned;
dcl	request_type	char (32);
dcl	segname_list_len	fixed bin (21);
dcl	segname_list_ptr	pointer;
dcl	segname_list_space	char (256) varying;
dcl	temp		fixed bin (35);

/* based */

dcl	abs_args_list	char (abs_args_list_len) varying based (abs_args_list_ptr);
dcl	argu		char (arglen) based (argp);
dcl	digit_pic		pic "9" based;
dcl	dp_args_list	char (dp_args_list_len) varying based (dp_args_list_ptr);
dcl	segname_list	char (segname_list_len) varying based (segname_list_ptr);
dcl	system_area	area based (areap);

/* builtin */

dcl	(binary, codeptr, convert, hbound, index, lbound, ltrim, max, maxlength, null, rtrim, string)
			builtin;

/* condition */

dcl	cleanup		condition;

/* internal static */

dcl	SP		char (1) internal static options (constant) initial (" ");
dcl	function		char (6) internal static options (constant) initial ("runoff");
dcl	function_abs	char (10) internal static options (constant) initial ("runoff_abs");

/* external static */

dcl	error_table_$badopt fixed bin (35) external static;

/* entry */

dcl	absolute_pathname_	entry (char (*), char (*), fixed bin (35));
dcl	com_err_		entry options (variable);
dcl	com_err_$suppress_name
			entry options (variable);
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	cv_dec_check_	entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl	enter_abs_request	entry options (variable);
dcl	expand_pathname_$add_suffix
			entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl	get_system_free_area_
			entry returns (ptr);
dcl	get_wdir_		entry returns (char (168) aligned);
dcl	hcs_$fs_get_path_name
			entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl	hcs_$status_minf	entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl	ioa_		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	requote_string_	entry (char (*)) returns (char (*));
dcl	suffixed_name_$new_suffix
			entry (char (*), char (*), char (*), char (32), fixed bin (35));
dcl	system_info_$default_absentee_queue
			entry (fixed bin);

/* format: inddcls */
%page;
/* program */

	areap = get_system_free_area_ ();

	abs_args_list_space = "";
	abs_args_list_ptr = addr (abs_args_list_space);
	abs_args_list_len = maxlength (abs_args_list_space);

	default_absentee_queue = "1"b;

	dp_args_list_space = "";
	dp_args_list_ptr = addr (dp_args_list_space);
	dp_args_list_len = maxlength (dp_args_list_space);

	error_sw = "0"b;
	hold = "dprint";				/* dprint runout(s) when done */
	limit_sw = "0"b;				/* no absentee timer limit */
	no_of_copies_str = "1";
	outsw = "0"b;				/* -output_file not used */
	request_type = "printer";

	segname_list_space = "";
	segname_list_ptr = addr (segname_list_space);
	segname_list_len = maxlength (segname_list_space);

	call system_info_$default_absentee_queue (absentee_queue_n);
	if absentee_queue_n = 0
	then absentee_queue_n = 3;			/* default default absentee queue */
	absentee_queue = convert (digit_pic, absentee_queue_n);
	dprint_queue = absentee_queue;

	call cu_$arg_count (argcount, code);
	if code ^= 0
	then do;
		call com_err_ (code, function_abs);
		return;
	     end;

	if argcount = 0
	then do;
		call com_err_$suppress_name (0, function_abs, "Usage: ^a paths {^a_args} {dp_args} {-control_args}",
		     function_abs, function);
		return;
	     end;

	on cleanup call cleaner_up ();

/* Start looking at arguments */

	do argno = 1 to argcount;			/* Loop ends at ENDLOOP */
	     call cu_$arg_ptr (argno, argp, arglen, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, function_abs, "Argument ^d.", argno);
		     goto REQUEST_NOT_SUBMITTED;
		end;

	     curarg = argu;

	     if index (argu, "-") ^= 1
	     then begin;
		     dcl	     bitcnt	     fixed bin (24);
		     dcl	     type		     fixed bin (2);

		     call expand_pathname_$add_suffix (argu, function, checkdir, checkent, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, function_abs, "^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     call hcs_$status_minf (checkdir, checkent, 1, type, bitcnt, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, function_abs, "^a^[>^]^a", checkdir, (checkdir ^= ">"), checkent);
			     error_sw = "1"b;
			end;

		     if segname_list = ""
		     then first_entryname = checkent;

		     call add_requoted (argu, segname_list_ptr, segname_list_len, addr (segname_list_space));
		     goto ENDLOOP;
		end;

/* Check for absentee control arguments */

	     else if argu = "-hold" | argu = "-hd"
	     then do;
		     hold = "hold";
		     goto ENDLOOP;
		end;

	     else if argu = "-limit" | argu = "-li"
	     then do;
		     limit_sw = "1"b;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code ^= 0 | temp <= 0
		     then do;
			     call com_err_ (0, function_abs, "Invalid limit. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     limit_no = temp;
		     goto ENDLOOP;
		end;

	     else if argu = "-queue" | argu = "-q"
	     then do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code = 0 & 1 <= temp & temp <= 4
		     then absentee_queue = convert (digit_pic, temp);
		     else do;
			     call com_err_ (0, function_abs, "Invalid queue number. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     default_absentee_queue = "0"b;
		     dprint_queue = absentee_queue;
		     goto ENDLOOP;
		end;

	     else if argu = "-output_file" | argu = "-of"
	     then do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     call absolute_pathname_ (argu, out_file, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, function_abs, "^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     outsw = "1"b;
		     goto ENDLOOP;
		end;

/* Is this a dprint option? */

	     else if argu = "-notify" | argu = "-nt" | argu = "-single" | argu = "-sg" | argu = "-no_endpage"
		     | argu = "-nep" | argu = "-non_edited" | argu = "-ned" | argu = "-access_label"
		     | argu = "-albl" | argu = "-truncate" | argu = "-tc" | argu = "-no_label" | argu = "-nlbl"
	     then do;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-destination" | argu = "-ds" | argu = "-header" | argu = "-he" | argu = "-label"
		     | argu = "-lbl" | argu = "-top_label" | argu = "-tlbl" | argu = "-bottom_label" | argu = "-blbl"
	     then do;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     call add_requoted (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-request_type" | argu = "-rqt"
	     then begin;
		     dcl	     gen_type	     char (32);

		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     call iod_info_$generic_type (argu, gen_type, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, function_abs, "Request type ^a.", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     if gen_type ^= "printer"
		     then do;
			     call com_err_ (0, function_abs, "Request type ^a is not for the printer.", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     request_type = argu;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-line_length" | argu = "-ll"
	     then do;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code ^= 0 | temp < 2 | temp > 136
		     then do;
			     call com_err_ (0, function_abs, "Invalid line length. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-page_length" | argu = "-pl"
	     then do;
		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code ^= 0 | temp < 2 | temp > 66
		     then do;
			     call com_err_ (0, function_abs, "Invalid page length. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     call add (argu, dp_args_list_ptr, dp_args_list_len, addr (dp_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-copy" | argu = "-cp"
	     then do;
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code = 0 & 1 <= temp & temp <= 4
		     then no_of_copies_str = convert (digit_pic, temp);
		     else do;
			     call com_err_ (0, function_abs, "Invalid number of copies. ^a", argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     goto ENDLOOP;
		end;

/* Check for runoff control arguments */

	     else if argu = "-hyphenate" | argu = "-hph" | argu = "-character" | argu = "-chars" | argu = "-ch"
		     | argu = "-no_pagination" | argu = "-npgn" | argu = "-number" | argu = "-nb"
	     then do;
		     call add (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-ball" | argu = "-bl" | argu = "-device" | argu = "-dv" | argu = "-from" | argu = "-fm"
		     | argu = "-indent" | argu = "-in" | argu = "-pass" | argu = "-page" | argu = "-pg" | argu = "-to"
	     then do;				/* requires a number */
		     call add (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     temp = cv_dec_check_ (argu, code);
		     if code ^= 0
		     then do;
			     call com_err_ (0, function_abs, "A number must follow ""^a""; not ""^a"".", curarg,
				argu);
			     goto REQUEST_NOT_SUBMITTED;
			end;

		     call add (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
		     goto ENDLOOP;
		end;

	     else if argu = "-parameter" | argu = "-pm"
	     then do;				/* must be followed by a string */
		     call add (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
		     argno = argno + 1;
		     call cu_$arg_ptr (argno, argp, arglen, code);
		     if code ^= 0
		     then goto TOO_FEW_ARGS;

		     call add_requoted (argu, abs_args_list_ptr, abs_args_list_len, addr (abs_args_list_space));
		     goto ENDLOOP;
		end;

ENDLOOP:
	end;

	if error_sw
	then goto REQUEST_NOT_SUBMITTED;

	if segname_list = ""
	then do;
		call com_err_ (0, function_abs, "No segments specified.");
		goto REQUEST_NOT_SUBMITTED;
	     end;

	if ^outsw
	then do;
		call suffixed_name_$new_suffix (first_entryname, function, "absout", checkent, code);
		if code ^= 0
		then do;
			call com_err_ (code, function_abs, "^a with absout suffix.", first_entryname);
			goto REQUEST_NOT_SUBMITTED;
		     end;

		out_file = checkent;
	     end;

	begin;
	     dcl	     default_queue	     fixed bin;
	     dcl	     max_queue	     fixed bin;

	     call iod_info_$queue_data (request_type, default_queue, max_queue, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, function_abs, "Request type ^a.", request_type);
		     goto REQUEST_NOT_SUBMITTED;
		end;

	     if default_absentee_queue		/* user didn't specify queue: use default without warnings */
	     then dprint_queue = convert (digit_pic, default_queue);

	     if binary (dprint_queue, 17) < 1 | max_queue < binary (dprint_queue, 17)
	     then do;
		     call com_err_ (0, function_abs,
			"Request type ^a does not have queue ^a. Dprint queue ^d assumed.", request_type,
			dprint_queue, max_queue);
		     dprint_queue = convert (digit_pic, max_queue);
		end;
	end;

	call hcs_$fs_get_path_name (codeptr (runoff_abs), checkdir, i, checkent, code);

	if limit_sw
	then call enter_abs_request (rtrim (checkdir) || ">runoff_abs_absin", "-queue", absentee_queue, "-restart",
		"-output_file", rtrim (out_file), "-limit", ltrim (limit_no), "-arguments", rtrim (get_wdir_ ()),
		dprint_queue, (hold), no_of_copies_str, ltrim (segname_list), ltrim (abs_args_list),
		ltrim (dp_args_list));

	else call enter_abs_request (rtrim (checkdir) || ">runoff_abs_absin", "-queue", absentee_queue, "-restart",
		"-output_file", rtrim (out_file), "-arguments", rtrim (get_wdir_ ()), dprint_queue, (hold),
		no_of_copies_str, ltrim (segname_list), ltrim (abs_args_list), ltrim (dp_args_list));

	call cleaner_up;

	return;


TOO_FEW_ARGS:
	call com_err_ (code, function_abs, "After ^a.", curarg);
	goto REQUEST_NOT_SUBMITTED;

UNREC_OPT:
	call com_err_ (error_table_$badopt, function_abs, "^a", argu);
	goto REQUEST_NOT_SUBMITTED;

REQUEST_NOT_SUBMITTED:
	call com_err_ (0, function_abs, "Absentee request not submitted.");
	call cleaner_up;

	return;
%page;
/* format: ^inddcls */

/* Add the argument to one of the arbitrarily lengthed output strings */

add:
     procedure (argument, output_ptr, output_len, output_space);

dcl	argument		character (*) parameter;
dcl	output_ptr	pointer parameter;
dcl	output_len	fixed binary (21) parameter;
dcl	output_space	pointer parameter;
dcl	requote_argument	bit (1) aligned;
dcl	new_min_maxlength	fixed binary (21);
dcl	old_output_len	fixed binary (21);
dcl	old_output_ptr	pointer;
dcl	output_string	character (output_len) varying based (output_ptr);
dcl	old_output_string	character (old_output_len) varying based (old_output_ptr);

	requote_argument = "0"b;
	goto START_ADDITION;

add_requoted:
     entry (argument, output_ptr, output_len, output_space);

	requote_argument = "1"b;

START_ADDITION:
	new_min_maxlength = length (output_string) + length (SP) + length (argument);
	if requote_argument				/* room for possible requoting */
	then new_min_maxlength = new_min_maxlength + length (argument) + 2;

	if new_min_maxlength > output_len
	then do;					/* need to make more space */
		old_output_ptr = output_ptr;
		old_output_len = output_len;
		output_len = max (2 * output_len, new_min_maxlength);
		allocate output_string in (system_area) set (output_ptr);
		output_string = old_output_string;
		if old_output_ptr ^= output_space
		then free old_output_string in (system_area);
	     end;

	output_string = output_string || SP;

	if requote_argument
	then output_string = output_string || requote_string_ (argument);
	else output_string = output_string || argument;

	return;

     end add;



cleaner_up:
     procedure;

	if abs_args_list_ptr ^= addr (abs_args_list_space)
	then free abs_args_list in (system_area);
	if dp_args_list_ptr ^= addr (dp_args_list_space)
	then free dp_args_list in (system_area);
	if segname_list_ptr ^= addr (segname_list_space)
	then free segname_list in (system_area);

	return;

     end cleaner_up;

     end runoff_abs;




		    request_info.pl1                10/28/88  1346.0r w 10/28/88  1258.0      259641



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-04-20,Parisek), approve(88-06-13,MCR7913),
     audit(88-08-16,Farley), install(88-08-22,MR12.2-1089):
     Initial coding.  Extracted code from list_abs_requests.pl1 and modified
     to meet the specific requirements of this command/AF.  This command calls
     lar_util_$request_info (new entrypoint developed to service this
     command) with three parameters, the pointer to the info structure, a
     switch designating whether or not rqi was invoked as active function,
     and finally the return error code.  SCP-6391.
                                                   END HISTORY COMMENTS */

/* format: off */

request_info:
rqi:	procedure;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Command/Active function to provide information on absentee, IO Daemon, retrieval	*/
          /* and imft requests                                                                      */
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl	
          abs_key                       bit(1),
	afsw                          bit(1) aligned,
	allsw                         bit(1) aligned,
	arg_msg			char(64),
	argptr			ptr,
	arglen			fixed bin(21),
	code			fixed bin(35),
	com_key                       bit(1),
	ctl_arg_given		bit(1),
	default_queue		fixed bin,
	dfi_arg                       char(32),
	dir			char(168),
	ds_arg                        char(32),
	ent			char(32),
	err_msg			char(256),
	fg_arg                        char(32),
	fg_sw                         bit(1),
	finish			fixed bin,
	foreground_sw		bit(1),
	gen_type			char(32),
	i			fixed bin,
	ignore_code		fixed bin(35),
	ii			fixed bin,
	iix			fixed bin,
	imft_dest                     char(32),
	imft_key                      bit(1),
	imft_source                   char(32),
	io_key                        bit(1),
	io_queue_name                 char(32),
	key_arg                       char(32),
	max_queue			fixed bin,
	min_queue			fixed bin,
	nargs			fixed bin,
	pch_arg                       char(32),
	plt_arg                       char(32),
	prt_arg                       char(32),
	priority			fixed bin,
	priority_q                    char(2),
          retlen                        fixed bin(21),
	retptr                        ptr,
	retv_key                      bit(1),
	rsc_arg                       char(32),
	rqt_arg                       char(32),
	rqt_key                       bit(1),
	rqi_key                       bit(1),
	rqt_type                      fixed bin,
	rs_len                        fixed bin,
	sc_arg                        char(32),
	sdr_arg                       char(32),
	start			fixed bin,
	tp			ptr,
	user_arg			bit(1) aligned;

    dcl	arg			char(arglen) unal based (argptr);
    dcl   ret_arg                       char(retlen) varying based (retptr);
    dcl   ret_data                      char(info.output_count) based (info.temptr);
		
    dcl  (addr, after, before, hbound, index, length, min, null, rtrim,
	substr, unspec) 		builtin;

    dcl	cleanup			condition;

    dcl   complain                      entry variable options (variable),
						/* com_err_ or active_fnc_err_ */
	get_argument                  variable entry (fixed bin, ptr, fixed bin(21), fixed bin (35)),
	active_fnc_err_               entry options (variable),
	com_err_			options (variable),
          cu_$af_return_arg             entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$af_arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cv_dec_check_		entry (char(*), fixed bin(35)) returns(fixed bin(35)),
	enter_output_request$default_request_type
				entry (char(*), char(*), fixed bin, fixed bin, fixed bin(35)),
	enter_output_request$request_type
				entry (char(*), char(*), char(*), fixed bin, fixed bin, fixed bin(35)),
	expand_pathname_		entry (char(*), char(*), char(*), fixed bin(35)),
	get_temp_segment_		entry (char(*), ptr, fixed bin(35)),
	hcs_$star_		entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr,
				     fixed bin(35)),
	message_segment_$close	entry (fixed bin, fixed bin(35)),
	message_segment_$open	entry (char(*), char(*), fixed bin, fixed bin(35)),
	ioa_$rsnnl		entry() options(variable),
	iod_info_$generic_type	entry (char(*), char(32), fixed bin(35)),
	iod_info_$queue_data	entry (char(*), fixed bin, fixed bin, fixed bin(35)),
	iox_$put_chars		entry (ptr, ptr, fixed bin(21), fixed bin(35)),
	lar_util_$request_info	entry (ptr, bit (1) aligned, fixed bin(35)),    
	release_temp_segment_	entry (char(*), ptr, fixed bin(35)),
	system_info_$default_absentee_queue
				entry (fixed bin);

    dcl	ALL                           fixed bin int static options (constant) init (1),
						/* bit position in com_keywords */
    	BRANCHES                      fixed bin(2) int static options (constant) init (2),
    	CURRENTLY_UNDEFINED           fixed bin int static options (constant) init (-1),
          IMFT                          fixed bin int static options (constant) init (5),
	POSITION                      fixed bin int static options (constant) init (4),
						/* bit position in com_keywords */
	QUEUE_NEG                     fixed bin int static options (constant) init (-1),
	QUEUE_1                       fixed bin int static options (constant) init (1),
	QUEUE_2                       fixed bin int static options (constant) init (2),
	QUEUE_3                       fixed bin int static options (constant) init (3),
	QUEUE_4                       fixed bin int static options (constant) init (4),
	abs_dir			char(168) int static init(">system_control_1"),
	id                            char(32) int static options (constant) init ("request_info"),
	iod_dir			char(168) int static init(">daemon_dir_dir>io_daemon_dir"),
	retriever_dir		char(168) int static init(">daemon_dir_dir>volume_retriever");

    dcl	error_table_$badopt		fixed bin(35) ext static,
	error_table_$id_not_found	fixed bin(35) ext static,
	error_table_$noarg		fixed bin(35) ext static,
	error_table_$not_act_fnc	fixed bin(35) ext static,
	iox_$user_output		ptr ext static;




	%include lar_info;

    dcl	1 local_info		like info aligned;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

 	call cu_$af_return_arg (nargs, retptr, retlen, code);
	if code = 0 then do;
 	     afsw = "1"b;
 	     complain = active_fnc_err_;
 	     get_argument = cu_$af_arg_ptr;
 	     ret_arg = "";
 	end;
 	else if code = error_table_$not_act_fnc then do;
 	     afsw = "0"b;
 	     complain = com_err_;
 	     get_argument = cu_$arg_ptr;
 	end;
	else if code ^= 0 then do;
	     call com_err_ (code, id);
	     return;
	end;		

	call init;				/* defaults */
	
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

	allsw,     
	ctl_arg_given,
	foreground_sw = "0"b;

	do i = 1 to nargs;
	     call get_arg (i);
	     if code ^= 0 then go to CHECK;		/* if no more arguments do consistency check */
	     if index(arg, "-") = 1 then do;		/* if argument is an option match it with acceptable options */
		ctl_arg_given = "1"b;
		if arg = "-user" |
		arg = "-am" | arg = "-admin" then do;
		     if arg = "-user" then user_arg = "1"b; /* remember if it was -user */
		     else user_arg = ""b;		/* or -admin */
		     info.admin_sw = "1"b;
		     call get_arg (i+1);		/* check for optional user name */
		     if code = 0			/* if there is an argument there */
		     & index(arg, "-") ^= 1 then do;	/* and it is not a control arg */
			if info.user_sw then do;	/* user given ... but user already given */
			     arg_msg = "User name given twice";
PRINT_ARG_ERR:		     call ioa_$rsnnl ("^a. ^a", err_msg, rs_len, arg_msg, arg);
			     call print_err_msg (0);
			     return;
			end;
			i = i + 1;		/* remember that we used this arg */
			info.user_sw = "1"b;
			info.person = before (arg, ".");
			info.project = before (after (arg, "."), ".");
			if info.person = "" then info.person = "*";
			if info.project = "" then info.project = "*";
		     end;
		     else if user_arg then do;	/* user name not optional after -user */
			code = error_table_$noarg;
			arg_msg = "After -user";
			goto PRINT_MISS_ARG;
		     end;
		end;

		else if arg = "-p" | arg = "-pn" | arg = "-pathname" then do;
		     if info.dirname_sw then do;
			if info.ename_sw then	/* -et already given */
			     arg_msg = "Pathname and entryname cannot both be given.";
			else arg_msg = "Pathname given twice";
			goto PRINT_ARG_ERR;
		     end;
		     i = i + 1;
		     call get_arg (i);		/* get PATH */
		     if code ^= 0 then do;
			arg_msg = "After -pn";
			goto PRINT_MISS_ARG;
		     end;
		     call expand_pathname_ (arg, info.dirname, info.ename, code);
		     if code ^= 0 then do;
			call ioa_$rsnnl ("Expanding pathname: ^a", err_msg, rs_len, arg);
			call print_err_msg (code);
			return;
		     end;
		     info.dirname_sw, info.path_sw = "1"b;
		end;
		else if arg = "-a" | arg = "-all" then info.all_opt_sw = "1"b; /* we'll check later */
		else if (arg = "-im" | arg = "-immediate") then do;
		     if info.request_type = RETV then do;
			err_msg = "Cannot specify -immediate with the retrieval request type.";
			call print_err_msg (0);
			return;
		     end;
		     info.immediate = "1"b;
		end;
		else if arg = "-q" | arg = "-queue" then do;
		     if info.q_opt_sw then do;
			arg_msg = "Queue option given twice";
			goto PRINT_ARG_ERR;
		     end;
		     i = i + 1;			/* get next argument - number indicating which queue */
		     call get_arg (i);
		     if code ^= 0 then do;
			arg_msg = "After -queue";
			goto PRINT_MISS_ARG;
		     end;
		     info.q_opt_sw = "1"b;		/* remember that it has been given */
		     priority_q = arg;		/* remember for CHECK */
		     if (arg = "fg" | arg = "foreground") then fg_sw = "1"b;
		end;
		else if arg = "-id" then do;
		     if info.id_sw then do;
			arg_msg = "Id option given twice";
			goto PRINT_ARG_ERR;
		     end;
		     i = i + 1;			/* next arg is the ID */
		     call get_arg (i);
		     if code ^= 0 then do;
			arg_msg = "After -id";
PRINT_MISS_ARG:		err_msg = arg_msg;
			call print_err_msg (code);
			return;
		     end;
		     info.id_sw = "1"b;
		     info.request_id = arg;
		end;
		else if arg = "-et" | arg = "-entry" then do;
		     if info.ename_sw then do;	/* entryname already given */
			if info.dirname_sw then
			     arg_msg = "Pathname and entry name cannot both be given";
			else arg_msg = "Entry name given twice";
			goto PRINT_ARG_ERR;
		     end;
		     i = i + 1;
		     call get_arg (i);
		     if code ^= 0 then do;
			arg_msg = "After -entry";
			goto PRINT_MISS_ARG;
		     end;
		     info.ename_sw = "1"b;
		     info.ename = arg;
		end;
		else if arg = "-forms" then do;
		     if info.forms_sw then do;
			arg_msg = "Forms given twice.";
			goto PRINT_ARG_ERR;
		     end;
		     call get_arg (i+1);		/* check for optional forms name */
		     if code = 0 & index (arg, "-") ^= 1 then do;
			i = i + 1;		/* increment arg index */
			info.forms_name = arg;	/* and save form name */
		     end;
		     else info.forms_name = "";	/* else show no form name given */
		     info.forms_sw = "1"b;
		end;
		else if arg = "-rsc" | arg = "-resource" then do;
		     info.resource_sw = "1"b;
		     rsc_arg = arg;
		     call get_arg (i+1);		/* look at next arg */
		     if code = 0			/* if there is an arg there */
			then if index(arg, "-") ^= 1 then do;
						/* and it's not a control arg */
						/* assume it's a resource name */
			     i = i + 1;		/* bump arg index */
			     if info.resource_name_sw then do;
				arg_msg = "Resource name given twice";
				goto PRINT_ARG_ERR;
			     end;
			     info.resource_name_sw = "1"b;
			     info.resource_name = arg;
			     if length (arg) > length (info.resource_name) then do;
				call ioa_$rsnnl ("Resource name too long; limit is ^d characters.",
				     err_msg, rs_len, length (info.resource_name));
				call print_err_msg (0);
				return;
			     end;
			end;
		end;
		else if arg = "-dfi" | arg = "-deferred_indefinitely" then do;
		     dfi_arg = arg;	
		     info.deferred_indefinitely = "1"b;
		end;
		else if arg= "-destination" | arg = "-ds" then do;
						/* IMFT ctl_arg */
		     if ds_arg ^= "" then do;
			arg_msg = "Destination given twice";
			goto PRINT_ARG_ERR;
		     end;
		     ds_arg = arg;
		     i = i + 1;
		     call get_arg (i);
		     if code ^= 0 then do;
			arg_msg = "After -destination";
			goto PRINT_MISS_ARG;
		     end;
		     imft_dest = arg;
		end;
		else if arg= "-source" | arg = "-sc" then do;
						/* IMFT ctl_arg */
		     if sc_arg ^= "" then do;
			arg_msg = "Source given twice";
			goto PRINT_ARG_ERR;
		     end;
		     sc_arg = arg;
		     i = i + 1;
		     call get_arg (i);
		     if code ^= 0 then do;
			arg_msg = "After -source";
			goto PRINT_MISS_ARG;
		     end;
		     imft_source = arg;
		end;
		else if arg = "-sender" then do;
		     if info.sender_sw then do;
			arg_msg = "Sender given twice";
			goto PRINT_ARG_ERR;
		     end;
		     sdr_arg = arg;	
		     i = i + 1;
		     call get_arg (i);
		     if code ^= 0 then do;
			arg_msg = "After -sender";
			goto PRINT_MISS_ARG;
		     end;
		     info.sender_sw = "1"b;
		     info.sender = arg;
		end;
		else if arg = "-fg" | arg = "-foreground" then do;
		     fg_arg = arg;	
		     foreground_sw = "1"b;
		end;
		else do;
		     err_msg = arg;
		     call print_err_msg (error_table_$badopt);
		     return;
		end;
               end;

	     else do;				/* not a control arg, might be a keyword or request type */
		do ii = 1 to hbound (com_keywords, 1) while
		     (com_keywords (ii) ^= arg);	/* check for common keys */
		end;
		if ii <= hbound (com_keywords, 1) then do;
		     iix = com_keyword_index (ii);
		     if iix = ALL | iix = POSITION then do;
			if iix = ALL then allsw = "1"b;
			info.position_sw = "1"b;	/* position or all */
		     end;
		     substr(info.com_rqi, iix, 1) = "1"b;
		     com_key = "1"b;		/* remember what key is being used */
		     rqi_key = "1"b;		/* remember that a key is specified */
		end;
		else do;
		     do ii = 1 to hbound (abs_keywords, 1) while
			(abs_keywords (ii) ^= arg);	/* check for abs keys */
		     end;
		     if ii <= hbound (abs_keywords, 1) then do;
			iix = abs_keyword_index (ii);
			substr(info.abs_rqi, iix, 1) = "1"b;
			abs_key = "1"b;
			rqi_key = "1"b;
		     end;
		     else do;
			do ii = 1 to hbound (output_keywords, 1) while
			     (output_keywords (ii) ^= arg);
						/* check for output/io keys */
			end;
			if ii <= hbound (output_keywords, 1) then do;
			     iix = output_keyword_index (ii);
			     substr(info.output_rqi, iix, 1) = "1"b;
			     io_key = "1"b;
			     rqi_key = "1"b;
			end;
			else do;
			     do ii = 1 to hbound (retv_keywords, 1) while
				(retv_keywords (ii) ^= arg);
						/* check for retrieval keys */
			     end;
			     if ii <= hbound (retv_keywords, 1) then do;
				iix = retv_keyword_index (ii);
				substr(info.retv_rqi, iix, 1) = "1"b;
				retv_key = "1"b;
				rqi_key = "1"b;
			     end;
			     else do;
				do ii = 1 to hbound (imft_keywords, 1) while
				     (imft_keywords (ii) ^= arg);
						/* check for imft keys */
				end;
				if ii <= hbound (imft_keywords, 1) then do;
				     iix = imft_keyword_index (ii);
				     substr(info.imft_rqi, iix, 1) = "1"b;
				     imft_key = "1"b;
				     rqi_key = "1"b;
				end;
				else if ^rqt_key then do;	/* check for request type key */
				     call look_rqt_key (substr(arg, 1, arglen));
						/* define the rqt */
				     key_arg = arg;
				     rqt_key = "1"b;
				     call init_rqt;
						/* initialize rqt dependent data */
				end;
				else do;		/* must be invalid keyword */
				     call ioa_$rsnnl ("Invalid keyword, ^a.",
					err_msg, rs_len, arg);
				     call print_err_msg (0);
				     return;
				end;
			     end;
			end;
		     end;
		end;
	     end;
	end;					/* end argument loop */

/* Now check the arguments for consistency */

CHECK:

	if ^rqt_key then do;			/* missing rqt key */
	     err_msg = "Missing request type keyword.";
	     call print_err_msg (0);
	     return;
	end;

	if ^rqi_key then do;			/* missing info key */
	     err_msg = "Missing request info keyword.";
	     call print_err_msg (0);
	     return;
	end;

	if allsw & afsw then do;
	     err_msg = "Keyword ""all"" not permitted with the active function.";
	     call print_err_msg (0);
	     return;
	end;

	if rqt_type = ABS & (^abs_key & ^com_key) then do;
incons_key:    err_msg = "request type key inconsistent with info key.";
	     call print_err_msg (0);
	     return;
	end;
	
	if (rqt_type = OUTPUT | rqt_type = IO) & (^io_key & ^com_key) then
	     goto incons_key;

	if rqt_type = RETV & (^retv_key & ^com_key) then goto incons_key;

	if rqt_type = IMFT & (^imft_key & ^com_key) then goto incons_key;

	if rqt_type ^= ABS then do;
	     if rsc_arg ^= "" then do;		/* -rsc given, but rqt not abs */
		err_msg = rtrim(rsc_arg) || " for " || key_arg;
		goto CHECK_BADOPT;
	     end;
	     else if dfi_arg ^= "" then do;		/* -dfi given, but rqt not abs */
		err_msg = rtrim(dfi_arg) || " for " || key_arg;
		goto CHECK_BADOPT;
	     end;
	     else if sdr_arg ^= "" then do;		/* -sender given, but rqt not abs */
		err_msg = rtrim(sdr_arg) || " for " || key_arg;
		goto CHECK_BADOPT;
	     end;
	     else if fg_arg ^= "" then do;		/* -foreground given, but rqt not abs */
		err_msg = rtrim(fg_arg) || " for " || key_arg;
		goto CHECK_BADOPT;
	     end;
	end;

	if rqt_type ^= IMFT & (ds_arg ^= "" | sc_arg ^= "") then do;
	     if ds_arg ^= "" then err_msg = rtrim(ds_arg) || " for " || key_arg;
						/* -dest given, but rqt not imft */
	     else err_msg = rtrim(sc_arg) || " for " || key_arg;
						/* -source given, but rqt not imft */
CHECK_BADOPT:  call print_err_msg (error_table_$badopt);
	     return;
	end;

	if info.all_opt_sw & info.q_opt_sw then do;
	     err_msg = "The -all and -queue control arguments are incompatible.";
	     call print_err_msg (0);
	     return;
	end;

	if info.q_opt_sw then do;
	     if fg_sw & rqt_type = ABS then priority = -1;/* foreground queue */
	     else do;
		priority = cv_dec_check_ (rtrim(priority_q), code);
		if code ^= 0 then do;
		     call ioa_$rsnnl ("Illegal queue number ^a", err_msg, rs_len, rtrim(priority_q));
		     call print_err_msg (0);
		     return;
		end;
	     end;
	     start, finish = priority;		/* specified queue */
	     if priority < min_queue | priority > max_queue then do;
		call ioa_$rsnnl ("-queue ^d is invalid.  Use a number from ^d to ^d.", err_msg, rs_len,
		     priority, min_queue, max_queue);
		call print_err_msg (0);
		return;
	     end;
	end;

	if (foreground_sw & (info.all_opt_sw | info.q_opt_sw)) |
	     (info.all_opt_sw & (info.q_opt_sw | foreground_sw)) |
	     (info.q_opt_sw & (info.all_opt_sw | foreground_sw)) then do;
	     call ioa_$rsnnl ("The following control arguments are incompatible: -foreground, -all, and -queue",
		err_msg, rs_len);
	     call print_err_msg (0);
	     return;
	end;

	if rqt_type = IMFT then do;
	     if imft_dest ^= "" then do;		/* -dest */
		info.queue_name = "To_" || rtrim(imft_dest);
		call iod_info_$generic_type (info.queue_name, gen_type, code);
		if code ^= 0 then do;
		     if code = error_table_$id_not_found then do;
id_not_found:		call ioa_$rsnnl ("Unknown request type.  ^a",
			     err_msg, rs_len, info.queue_name);
			call print_err_msg (code);
			return;
		     end;
		     else do;
rqt_warning:		call ioa_$rsnnl ("Warning -- Unable to check request type ^a.",
			     err_msg, rs_len, io_queue_name);
			call print_err_msg (code);
		     end;
		end;
		else call iod_info_$queue_data (info.queue_name, default_queue, max_queue, ignore_code);
	     end;
	     else if imft_source ^= "" then do;		/* -sc */
		info.queue_name = "From_" || rtrim(imft_source);
		call iod_info_$generic_type (info.queue_name, gen_type, code);
		if code ^= 0 then do;
		     if code = error_table_$id_not_found then
			goto id_not_found;
		     else goto rqt_warning;
		end;
		else call iod_info_$queue_data (info.queue_name, default_queue, max_queue, ignore_code);
	     end;
	end;


/* Now set first and last queue according to arguments or defaults (but -q argument processing sets them in-line) */

	if info.all_opt_sw then do;			/* all queues */
	     start = min_queue;
	     finish = max_queue;
	end;
	else if foreground_sw then			/* only foreground queue */
	     start, finish = -1;
	else if ^info.q_opt_sw then do;		/* no queue specified - set defaults */
	     start = min_queue;			/* that is, search all queues */
	     finish = max_queue;
	     info.search_all = "1"b;			/* but only print for queues that we select requests from */

	end;
	if info.request_type = ABS then do;		/* for absentee queues */
	     if start = 1 then			/* if user said -q 1 */
		start = 0;			/* we pretend queue 0 is the first part of queue 1 */
	     if start <= 0				/* if listing queue 0 */
	     & finish >= 1				/* and also queue 1 */
	     then info.abs_q_1 = "1"b;		/* turn on the "pretend they are one queue" switch */
	end;

/* Arguments are ok. Get ready to call lar_util_$request_info. First, get a temp segment for lar_util_ to build the listing in. */

	info.mseg_idx = 0;				/* no open mseg */

/* CONDITION HANDLER FOR cleanup */

	on condition (cleanup) begin;			/* but first be sure we will give it back no matter what */
	     if info.mseg_idx ^= 0 then		/* if we have an open mseg */
		call message_segment_$close (info.mseg_idx, ignore_code);
	     if tp ^= null then			/* if we have a temp seg */
		call release_temp_segment_ (id, tp, code); /* give it back */
	end;					/* end begin block */

/* END CONDITION HANDLER */

	call get_temp_segment_ (id, tp, code);
	if code ^= 0 then do;
	     err_msg = "temporary segment";
	     call print_err_msg (code);
	     return;
	end;

/* Initialize, before entering loop over queues */

	info.temptr = tp;

/* Beginning of loop over one or more queues */

	do info.queue = start to finish;
	     if info.queue = -1 then ent = "absentee_foreground.ms"; /* construct entry name of message segment */
	     else call ioa_$rsnnl ("^a_^d.ms", ent, rs_len, info.queue_name, info.queue);
	     call message_segment_$open (dir, ent, info.mseg_idx, code); /* initiate message segment containing requests */
	     if code = 0 then do;			/* if we opened it successfully, go list it */

/* call lar_util_$request_info, which will build up a listing of this queue's requests, in a printable segment */

		call lar_util_$request_info (info_ptr, afsw, code);
						/* get information on requests in this queue */
		call message_segment_$close (info.mseg_idx, ignore_code);
						/* close message segment */
	     end;
	     if code ^= 0 then do;
		call ioa_$rsnnl ("^[Attempting to open^x^;^]^a>^a", err_msg, rs_len, (info.mseg_idx = 0), dir, ent);
		call print_err_msg (code);
	     end;
	     info.mseg_idx = 0;			/* so cleanup handler doesn't try to close it again */
	     info.input_count = info.output_count;	/* copy new length of temorary */
	end;

/* End of loop over queues. Now print the info produced by lar_util_$request_info. */

	if info.output_count > 1 then do;
	     if afsw then do;
		info.output_count = info.output_count - 1;   /* remove the xtra char placed at end of string */
		ret_arg = ret_data;
	     end;
	     else do;
		if allsw then info.output_count = info.output_count - 1;
						/* if all, then remove trailing NL */
		call iox_$put_chars (iox_$user_output, info.temptr, info.output_count, code);
		if code ^= 0 then do;
		     err_msg = "user_output";
		     call print_err_msg (code);
		end;
	     end;
	end;

/* This is the main exit from this procedure */

ERROR_EXIT:
	if tp ^= null() then call release_temp_segment_ (id, tp, code);
	return;




test_rqi:	entry (rqt_test, sys_dir_test);		/* entry point for testing rqi command		*/

    dcl	sys_dir_test		char(*);
    dcl   rqt_test                      char(*);

	if rqt_test = "absentee" | rqt_test = "abs" then
	     abs_dir = sys_dir_test;
	else if rqt_test = "output" | rqt_test = "out" | rqt_test = "io" |
	     rqt_test = "imft" then
	     iod_dir = sys_dir_test;
	else if rqt_test = "retrieval" | rqt_test = "retv" then
	     retriever_dir = sys_dir_test;
	return;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	INTERNAL	 PROCEDURES						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


get_arg:	proc (argno);

    dcl	argno			fixed bin;

	     call get_argument (argno, argptr, arglen, code);
	     return;

	end get_arg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


init:	proc;

	tp = null();
	rqi_key, rqt_key, abs_key, com_key, io_key, imft_key, retv_key
	     = "0"b;
	dfi_arg, ds_arg, fg_arg, imft_dest, imft_source, pch_arg,
	     plt_arg, prt_arg, rsc_arg, rqt_arg, sdr_arg, sc_arg = "";

	info_ptr = addr (local_info);
	unspec (info) = ""b;			/* zero everyting in info structure */

	return;

	end init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


print_err_msg: proc (ec);

dcl	ec			fixed bin(35);	/* error code */

/* The global variable, err_msg, is an implicit argument */

	     call complain (ec, id, err_msg);
	     return;

	end print_err_msg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

look_rqt_key:
	proc (key);
     dcl key char (*) parm;
	
	if key = "absentee" | key = "abs" then rqt_type = ABS;
	else if key = "retrieval" | key = "retv" then rqt_type = RETV;
	else if key = "io" then rqt_type = IO;
	else if key = "imft" then rqt_type = IMFT;
	else if key = "output" | key = "out" then rqt_type = OUTPUT;
	else rqt_type = CURRENTLY_UNDEFINED;		/* could be a user-defined rqt */

	return;

     end look_rqt_key;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

init_rqt:
          proc ();

	if rqt_type = OUTPUT | rqt_type = IO then do;	/* OUTPUT/IO */
	     min_queue = 1;
	     dir = iod_dir;
	     call enter_output_request$default_request_type ("printer",
		info.queue_name, default_queue, max_queue, code);
	     if code ^= 0 then goto undef_rqt;
	     info.request_type = OUTPUT;
	end;
	else if rqt_type = CURRENTLY_UNDEFINED then do;	/* Possibly user-defined */
	     call enter_output_request$request_type (key_arg, gen_type,
		info.queue_name, default_queue, max_queue, code);
	     if code ^= 0 then do;
undef_rqt:	call ioa_$rsnnl ("Getting request type defaults for ^a.", err_msg, rs_len, key_arg);
		call print_err_msg (code);
		goto ERROR_EXIT;
	     end;
	     min_queue = QUEUE_1;
	     dir = iod_dir;
	     if gen_type = "imft" then info.request_type = IMFT;
	     else info.request_type = OUTPUT;
	end;
	else if rqt_type = ABS then do;		/* ABS */
	     call system_info_$default_absentee_queue (default_queue);
	     if default_queue = 0 then default_queue = QUEUE_3;
	     max_queue = QUEUE_4;
	     min_queue = QUEUE_NEG;
	     dir = abs_dir;
	     info.queue_name = "absentee";
	     info.request_type = ABS;
	end;
	else if rqt_type = RETV then do;		/* RETV */
	     call hcs_$star_ (retriever_dir, "volume_retriever*.ms", BRANCHES,
		null, max_queue, (null), (null), code);
	     if code ^= 0 then
		max_queue = QUEUE_3;
	     default_queue = min (max_queue, QUEUE_3);
	     min_queue = QUEUE_1;
	     dir = retriever_dir;
	     info.queue_name = "volume_retriever";
	     info.request_type = RETV;
	end;
	else if rqt_type = IMFT then do;		/* IMFT */
	     call iod_info_$queue_data ("imft", default_queue, max_queue, code);
	     if code ^= 0 then do;
		max_queue = QUEUE_4;
		default_queue = QUEUE_2;
	     end;
	     min_queue = QUEUE_1;
	     dir = iod_dir;
	     gen_type = "imft";
	     info.queue_name = "imft";
	     info.request_type = IMFT;
	end;

     end init_rqt;

     end request_info;






		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
