



		    assign_resource.pl1             07/18/86  1500.4rew 07/18/86  1235.1      278289



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




/****^  HISTORY COMMENTS:
  1) change(86-05-22,Martinson), approve(86-05-22,MCR7411),
     audit(86-05-22,GJohnson), install(86-05-22,MR12.0-1061):
     Fix assign_resource so that the -wait control argument works.
  2) change(86-06-04,Hartogs), approve(86-06-04,MCR7383),
     audit(86-06-05,Coppola), install(86-07-18,MR12.0-1098):
     Changed to use version constant in rcp_device_info.incl.pl1
                                                   END HISTORY COMMENTS */


assign_resource: ar: procedure;


/*	This program is a command that may be called to assign a resource controled by RCP.
   *	Created on 01/07/75 by Bill Silver.
   *	Changed on 04/02/76 by Bill Silver for "-number" and "-wait" arguments.
   *	Changed on 05/24/78 by Michael R. Jordan for tape_drive and disk_drive and the waring for tape and disk.
   *	Changed on 11/17/78 by M. R. Jordan for -speed and -den 6250.
   *	Modified 6/79 by Michael R. Jordan for 32 character resource types.
   *      Changed 05/83 by B. Braun to add active function capability (phx14713) 
   *      and correct declarations of structures used in ipc_ calls (phx13447).
   *	Modified  9/83 by J. A. Bush to use tape_info_version_3 tape_info structure
   *	Modified 831010 for multiple console support... -E. A. Ranzenbach
   *      Modified 841017 to do correct cleanup handling... -M. M. Pozzo
   *
   *	In the current implementation this command can assign only devices.
   *	Its calling sequence is:
   *
   *	assign_resource  resource_type  -control_args-
   *
   *	resource_type	This argument specifies the type of resource to be
   *			assigned.  Currently only device type resources can
   *			be assigned.  Thus this argument must specify a known
   *			device type.  If no "-device" control argument is
   *			specified RCP will attempt to assign any appropriate
   *			device of this type.
   *
   *	The following optional control arguments are also supported.  They may
   *	be used to specify the characteristics of the device to be assigned.
   *	Most of these control arguments must be followed by a value argument.
   *
   *	(-dv  | -device)	Specifies that a specific device is to be assigned.
   *			Its value argument must be the name of the device.
   *			RCP will attempt to assign only this specific device.
   *	(-lg  | -long)	Specifies that the user wants all available information about
   *			the device that is assigned.
   *	(-com | -comment)	The value argument is a comment that will be displayed
   *			to the operator when the device is assigned.  If more
   *			than one term is required they should be in quotes.
   *	(-model)		Device model number.
   *	(-tk  | -track)	For tapes, the track type.  Must be 9 or 7.
   *	(-den | -density)	For tapes, the density must be one of the following
   *			values:  6250, 1600, 800, 556, or 200.
   *	(-vol | -volume)	The name of a volume used to qualify assignment.
   *	(-tn  | -train)	For printers, the print train type.
   *	(-ll  | -line_length)  For printer, the line length.
   *	(-sys | -system)	Specifies that the user wants to be a system process.
   *	(-nb  | -number)    The number of similar devices to assign.
   *	(-wt  | -wait)	Specifies that the user wants to wait for assignments.
   *			Optional value => minutes to wait.
   *	(-speed)		For tapes, the speed must be one of the following
   *			values: 75, 125, or 200.
   *
   *      Active Function Syntax is:
   *            [ar resource_type {-control_args}]
   *	 
   *      The active function returns true if an
   *	assignment was successful and returns false if the resources are
   *	unavailable.  Other errors are reported by active_fnc_error_.
   *	The -long control argument is not allowed.  
*/

/*		AUTOMATIC  DATA		*/

dcl 1 info_buffer like tape_info;			/* An input device info buffer big enough for tapes. */

dcl 1 alist (16) aligned,				/* List of assigned devices. */
    2 rcp_id bit (36),				/* RCP ID for this assignment. */
    2 info like tape_info;				/* Output device info structure. */

dcl 1 event_data aligned like event_wait_info;		/* Event message structure, not used. */

dcl  active_fnc			bit(1);		/* True if called as an active function 	*/
dcl  af_return_arg_len		fixed bin(21);	
dcl  af_return_arg_ptr		ptr;
dcl  arg_len fixed bin(21);				/* Length of an argument string.		*/
dcl  arg_ptr ptr;					/* Pointer to an argument string.		*/
dcl  argx fixed bin;				/* Number of the current argument.		*/
dcl  badx fixed bin (35);				/* Index to bad character.			*/
dcl  comment char (64);				/* Comments to and from operator.		*/
dcl  density bit (5);				/* Tape density characteristic.		*/
dcl  density_comment char (30) varying;			/* Used to print density capabilities.		*/
dcl  device_flag bit (1);				/* ON => user wants specific device by name.	*/
dcl  device_type char (32);				/* Device type.				*/
dcl  dtypex fixed bin;				/* Device type index.			*/
dcl  ecode fixed bin (35);				/* error_table_ code.			*/
dcl  fixed_arg fixed bin;				/* Used to convert an argumment to fixed bin.	*/
dcl  i fixed bin;
dcl  line_length fixed bin;				/* Printer line length.			*/
dcl  long_flag bit (1);				/* ON => all available information.		*/
dcl  max_num_waits fixed bin;				/* Maximum number of minutes to wait.		*/
dcl  num_args fixed bin;				/* Number of command arguments.		*/
dcl  num_assigned fixed bin;				/* Number of devices assigned so far.		*/
dcl  num_waits fixed bin;				/* Number of times we have waited.		*/
dcl  number fixed bin;				/* Number of devices to assign.		*/
dcl  option char (12);				/* Command option string.			*/
dcl  option_code fixed bin;				/* 0 => none,  1 => string,  2 => binary.	*/
dcl  print_train fixed bin;				/* Printer print train characteristic.		*/
dcl  speed bit (3);					/* Tape drive speed characteristics.		*/
dcl  speed_comment char (30) varying;			/* Used to print speed capability.		*/
dcl  statex fixed bin;				/* State of device assignment.		*/
dcl  system_flag bit (1);				/* ON => user wants to be a system process.	*/
dcl  temp_ecode fixed bin (35);
dcl  tracks fixed bin;				/* Tape track characteristic.			*/
dcl  volume_name char (32);				/* Tape or disk volume name.			*/
dcl  wait_flag bit (1);				/* ON => waiting for assignment.		*/


/*		BASED  DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Used to reference argument string. */
dcl af_return_arg			char(af_return_arg_len) varying based (af_return_arg_ptr);

/*		INTERNAL STATIC DATA	*/

dcl  brief_options (13) char (6)			/* Brief form of command options. */
     internal static init ("-dv", "-lg", "-com", "-model", "-tk", "-den",
     "-vol", "-tn", "-ll", "-sys", "-nb", "-wt", "-speed") options(constant);

dcl  long_options (13) char (12)			/* Long  form of command options. */
     internal static init ("-device", "-long", "-comment", "-model", "-track", "-density",
     "-volume", "-train", "-line_length", "-system", "-number", "-wait", "-speed") options(constant);

dcl  option_codes (13) fixed bin			/* Used to describe value argument. */
     internal static init (1, 0, 1, 2, 2, 2, 1, 2, 2, 0, 2, -2, 2) options(constant);

dcl  density_names (5) char (5) varying			/* Tape density capabilities. */
     internal static init ("200 ", "556 ", "800 ", "1600 ", "6250 ") options(constant);

dcl  density_values (5) fixed bin			/* Tape density values. */
     internal static init (200, 556, 800, 1600, 6250) options(constant);

dcl  console_models (4) char (4)			/* Operator's console model names. */
     internal static init ("IBM", "EMC", "SCC", "LCC") options(constant);

dcl  speed_values (3) fixed bin			/* Tape drive speed values. */
     internal static init (75, 125, 200) options(constant);

dcl  speed_names (3) char (4) varying			/* Tape drive speed names. */
     internal static init ("75 ", "125 ", "200 ") options(constant);


/*		EXTERNAL ENTRIES CALLED	*/

dcl  cleanup condition;				/* Used to unassign if trouble. */

dcl (addr, hbound, substr, null) builtin;

dcl (error_table_$action_not_performed,
     error_table_$bad_arg,
     error_table_$badopt,
     error_table_$inconsistent,
     error_table_$noarg,
     error_table_$not_act_fnc,
     error_table_$resource_reserved,
     error_table_$resource_unavailable,
     error_table_$wrong_no_of_args) fixed bin (35) external;

dcl  active_fnc_err_		entry options(variable),
     com_err_			entry options (variable),
     convert_ipc_code_ entry (fixed bin (35)),
     cu_$af_arg_ptr			entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
     cu_$af_return_arg		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
     cu_$arg_ptr			entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cv_dec_check_			entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     get_argument			entry (fixed bin, ptr, fixed bin(21), fixed bin(35)) variable,
     error_rtn_			entry() options(variable) variable,
     ioa_				entry options (variable),
     ipc_$block			entry (ptr, ptr, fixed bin (35)),
     ipc_$create_ev_chn		entry (fixed bin (71), fixed bin (35)),
     ipc_$delete_ev_chn		entry (fixed bin (71), fixed bin (35)),
     rcp_$assign_device		entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35)),
     rcp_$check_assign		entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (35)),
     rcp_$unassign			entry (bit (36) aligned, bit (*), char (*), fixed bin (35)),
     resource_info_$get_dtypex	entry (char (*), char (*), fixed bin, fixed bin (35)),
     timer_manager_$sleep		entry (fixed bin (71), bit (2));

%include rcp_device_info;

%include rcp_tape_info;

%include rcp_disk_info;

%include rcp_printer_info;

%include event_wait_channel;

%include event_wait_info;
%page;
/*
   *
   *	     Begin command:  assign_resource, ar
   *
*/


	device_flag,				/* Now initialize other variables. */
	     long_flag,
	     system_flag,
	     wait_flag = "0"b;

	dtypex,
	     ecode,
	     num_assigned,
	     event_wait_channel.channel_id(1) = 0;

	number = 1;

	comment = " ";

	do i = 1 to hbound (alist, 1);
	     alist (i).rcp_id = "0"b;
	end;
	device_info_ptr = addr (info_buffer);		/* All structures use the same buffer. */

	device_info.version_num = DEVICE_INFO_VERSION_1;			/* Set up assignment data.  Assume same version. */
	device_info.usage_time,			/* These fields not used yet. */
	     device_info.wait_time = 0;
	device_info.device_name = " ";		/* Blank => assign any device of specified type. */
	device_info.model = 0;
	device_info.qualifiers (*) = 0;

	tracks = 0;				/* Initialize device characteristics. */
	density = "0"b;
	volume_name = " ";
	speed = "0"b;
	print_train,
	     line_length = 0;

          /* get command arguments */
	call cu_$af_return_arg (num_args, af_return_arg_ptr, af_return_arg_len, ecode);	
          if ecode = error_table_$not_act_fnc then do;
	   active_fnc = "0"b;
	   get_argument = cu_$arg_ptr;
	   error_rtn_ = com_err_;
	   end;
          else do;					/* active function case			*/
	   active_fnc = "1"b;
	   get_argument = cu_$af_arg_ptr;
	   error_rtn_ = active_fnc_err_;
	   af_return_arg = "false";
	   end;

	call GET_RESOURCE_TYPE;			/* Get required argument. */
	if ecode ^= 0 then goto MAIN_RETURN;

	do argx = 2 to num_args;			/* Process any optional control arguments. */
	     call PROCESS_ARG;			/* Most will be processed in pairs. */
	     if ecode ^= 0 then goto MAIN_RETURN;	/* Was there an error? */
	end;

	call CHECK_DEVICE_INFO;			/* See if device info is valid. */
	if ecode ^= 0 then goto MAIN_RETURN;		/* Is it valid? */

	on cleanup begin;				/* If user quits unassign all devices. */
	     call CLEANUP;
	end;

	call ipc_$create_ev_chn (event_wait_channel.channel_id(1), ecode);
	if ecode ^= 0				/* RCP needs an event channel. */
	then do;					/* But we don't have one. */
	     call convert_ipc_code_ (ecode);
	     call error_rtn_ (ecode, "assign_resource", "Error creating event channel.");
	     goto MAIN_RETURN;
	end;

	do while ((num_assigned < number) & (ecode = 0));
	     call ASSIGN_DEVICE;			/* Try to assign one device. */
	end;

	if ecode ^= 0				/* Was there an error. */
	then goto MAIN_RETURN;			/* Yes. */

       
/*          Successful assignment of resources  */

	if active_fnc then af_return_arg = "true";	/* Active Function case prints no info.		*/
	else do;
	   if (long_flag) & (^device_flag) & (num_assigned > 1)
	   then call ioa_ ("^d devices assigned", num_assigned);

	   do number = 1 to num_assigned;		/* Print info about each assigned device. */
	     device_info_ptr = addr (alist (number).info);
	     call PRINT_DEVICE_INFO;			/* Print info about one device. */
             end;
	end;

	num_assigned = 0;				/* Don't unassign any devices.                    */
MAIN_RETURN:
	call CLEANUP;				/* Clean up event channel.			*/

	return;					/* We are finished.				*/
	

/*
   *
   *	This procedure will attempt to assign one device.
   *	If this device cannot be assigned because no appropriate device is
   *	currently available, then all devices assigned up to that point will
   *	be unassigned.  If the user wants to wait for the assignment(s) then
   *	we will go blocked for one minute and try again.
   *
   */


ASSIGN_DEVICE: procedure;


	     num_assigned = num_assigned + 1;		/* Up count of assigned devices. */
	     device_info_ptr = addr (info_buffer);	/* Use input info structure. */

	     call rcp_$assign_device (device_type, device_info_ptr, event_wait_channel.channel_id(1), comment,
		alist (num_assigned).rcp_id, ecode);
	     if ecode ^= 0				/* Was assignment started OK? */
	     then do;				/* No. */
		if (ecode ^= error_table_$resource_unavailable) &
		     (ecode ^= error_table_$resource_reserved)
		     then do;				/* Error during assignment. */
		     call error_rtn_ (ecode, "assign_resource", "Error assigning ^a device ^a",
			device_type, device_info.device_name);
		     return;
		     end;
		end;
	     device_info_ptr = addr (alist (num_assigned).info); /* Get pointer to output info structure. */
	     device_info.version_num = addr (info_buffer) -> device_info.version_num;
	     device_info.device_name = " ";


ASSIGN_LOOP:					/* Loop until assignment completed. */
	     comment = " ";
	     call rcp_$check_assign (alist (num_assigned).rcp_id, device_info_ptr, comment, statex, ecode);
	     if comment ^= " "			/* Did RCP send a comment? */
	     then if ^active_fnc then call ioa_ ("RCP comment: ^a", comment);

	     goto STATE (statex);			/* Process current state of assignment. */


STATE (0):					/* Assignment completed OK. */
	     return;


STATE (1):					/* Short wait, block until wakeup comes. */
	     call ipc_$block (addr (event_wait_channel), addr (event_data), ecode);
	     if ecode ^= 0				/* Error in blocking is bad. */
	     then do;
		call convert_ipc_code_ (ecode);
		call error_rtn_ (ecode, "assign_resource", "Error waiting for device assignment.");
		return;
	     end;
	     goto ASSIGN_LOOP;			/* Waked up, check assignment again. */


STATE (2):					/* Long wait, don't support this yet. */
	     ecode = error_table_$action_not_performed;


STATE (3):					/* Fatal error. */
	     if (ecode ^= error_table_$resource_unavailable) &
	     (ecode ^= error_table_$resource_reserved)
	     then do;				/* Error during assignment. */
		call error_rtn_ (ecode, "assign_resource", "Error assigning ^a device ^a",
		     device_type, device_info.device_name);
		return;
	     end;

	     if ^wait_flag                                /* Can't get device now, should we wait? */
	     then do;				/* No. */
	          if active_fnc then return;
		call error_rtn_ (ecode, "assign_resource", "Unable at this time to assign ^a device ^a",
		     device_type, device_info.device_name);
		return;
	     end;

/*	Assignment can be made if we wait.  Check to see if we have already
   *	waited too many times.
*/
	     if num_waits = max_num_waits		/* Have we waited to many times? */
	     then do;				/* Yes. */
	          if active_fnc then return;
		call error_rtn_ (ecode, "assign_resource", "Maximum wait of ^d minutes exceeded", max_num_waits);
		return;
	     end;

/*	We will wait for the assignment(s).  First unassign any device already assigned.
*/
	     alist (num_assigned).rcp_id = "0"b;	/* This assignment failed. */
	     do i = 1 to (num_assigned -1);		/* Unassign any devices already assigned. */
		call rcp_$unassign (alist (i).rcp_id, "0"b, "", temp_ecode);
		alist (i).rcp_id = "0"b;		/* Don't use this RCP ID again. */
		if temp_ecode ^= 0
		then do;				/* Error unassigning this device. */
		     call error_rtn_ (temp_ecode, "assign_resource", "Error unassigning device");
		     if ecode = 0 then ecode = temp_ecode;
		end;
	     end;

	     if num_waits = 0			/* Is this the first wait? */
	     then if ^active_fnc then call error_rtn_ (0, "assign_resource", "Waiting for device assignments");

	     num_waits = num_waits + 1;		/* Count number of times we have waited. */
	     num_assigned = 0;			/* No devices now assigned. */

	     call timer_manager_$sleep (60, "11"b);	/* Wait for one minute. */

	     ecode = 0;
	     return;

	end ASSIGN_DEVICE;

/*
   *
   *	This procedure is called to validate the data entered for this device
   *	assignment.  The actual testing performed depends upon the type of
   *	device being assigned.  If everything is OK we will fill in the device
   *	characteristics that go with this device type.
   *
   */


CHECK_DEVICE_INFO: procedure;


	     if (device_flag) & (number > 1)		/* Only one specific device can be assigned. */
	     then do;				/* More than one is an error. */
		ecode = error_table_$inconsistent;
		call error_rtn_ (ecode, "assign_resource", "Attempt to assign device ^a ^d times",
		     device_info.device_name, number);
	     end;

	     device_info.system_flag = system_flag;	/* Tell RCP whether or not this is a system process. */
	     goto DTYPE_CHECK (dtypex);		/* Go check depending upon device type. */


DTYPE_CHECK (1):					/* TAPE */
	     if (tracks = 0) &			/* If no track type specified ... */
	     (volume_name = " ")			/* and no volume specified ... */
	     then tracks = 9;			/* then use default track type. */
	     if (tracks = 7) &			/* Check that tracks and density are OK. */
	     (substr (density, 4, 2) ^= "00"b)
	     then do;				/* 7 track and 1600 is invalid. */
		ecode = error_table_$inconsistent;
		call error_rtn_ (ecode, "assign_resource", "Inconsistent track and density values.");
	     end;
	     tape_info_ptr = device_info_ptr;		/* Get pointer to tape_info structure. */
	     tape_info.version_num = tape_info_version_3; /* newer version than the others */
	     tape_info.tracks = tracks;		/* Fill in tape characteristics. */
	     tape_info.density = density;
	     tape_info.volume_name = volume_name;
	     tape_info.write_flag = "0"b;
	     tape_info.position_index = 0;
	     tape_info.speed = speed;
	     tape_info.unused_qualifier = "0"b;
	     return;


DTYPE_CHECK (2):					/* DISK */
	     disk_info_ptr = device_info_ptr;		/* Get pointer to disk_info structure. */
	     disk_info.volume_name = volume_name;	/* Fill in disk characteristics. */
	     disk_info.write_flag = "0"b;
	     return;


DTYPE_CHECK (3):					/* CONSOLE */
	     if (device_info.device_name ^= " ") &	/* Does user want specific device? */
	     (substr (device_info.device_name, 1, 3) ^= "opc")
	     then do;				/* Yes, but not the correct name. */
		ecode = error_table_$bad_arg;
		call error_rtn_ (ecode, "assign_resource", "Illegal console device name: ^a",
		     device_info.device_name);
	     end;
	     return;


DTYPE_CHECK (4):					/* PRINTER */
	     printer_info_ptr = device_info_ptr;	/* Get pointer to printer_info structure. */
	     printer_info.print_train = print_train;	/* Fill in printer characteristics. */
	     printer_info.line_length = line_length;
	     return;


DTYPE_CHECK (5):					/* PUNCH */
DTYPE_CHECK (6):					/* READER */
	     return;				/* Nothing to do for these device types. */


DTYPE_CHECK (7):					/* SPECIAL */
	     if device_info.device_name = " "		/* Did user specify a device name? */
	     then do;				/* No, for this device type he must. */
		ecode = error_table_$noarg;
		call error_rtn_ (ecode, "assign_resource", "Must specify SPECIAL device name.");
	     end;


	end CHECK_DEVICE_INFO;

/*
   *
   *	This procedure is called when the assignment has been aborted.
   *	If we have an RCP ID we will try to unassign the device we are assigning.
   *	If we have created an event channel then we must delete it.
   *
   */


CLEANUP:	procedure;

      dcl cleanup_code fixed bin (35);

	     do i = 1 to num_assigned;		/* Unassign all assigned devices. */
		if alist (i).rcp_id ^= "0"b		/* If we have an RCPID try to unassign. */
		then call rcp_$unassign (alist (i).rcp_id, "0"b, "", cleanup_code);
	     end;

	     if event_wait_channel.channel_id(1) = 0 then return;	/* Did we created an event channel? */

	     call ipc_$delete_ev_chn (event_wait_channel.channel_id(1), cleanup_code);

          return;

	end CLEANUP;

/*
   *
   *	This procedure is called to get the resource type to be assigned.
   *	The resource type name must be the first argument to this command.
   *
   */



GET_RESOURCE_TYPE: procedure;


	     if num_args < 1			/* Is there a resource type argument. */
	     then do;				/* No. */
		ecode = error_table_$noarg;
		call error_rtn_ (ecode, "assign_resource", "No resource type specified.");
		return;
	     end;

	     call get_argument (1, arg_ptr, arg_len, ecode); /* Get resource type argument. */
	     if ecode ^= 0
	     then do;
		call error_rtn_ (ecode, "assign_resource", "Error getting resource type argument");
		return;
	     end;

	     call resource_info_$get_dtypex (argument, device_type, dtypex, ecode);
	     if ecode ^= 0 then do;
		call error_rtn_ (ecode, "assign_resource", "^a", argument);
		return;
	     end;
	     else return;


	end GET_RESOURCE_TYPE;

/*
   *
   *	This procedure is called to get any value argument associated with this option.
   *	Processing of the value argument depends upon the option code value associated
   *	with this option.  The option code values are:
   *
   *	     0. This option argument has no accompanying value argument.
   *	     1. This option argument has a string type value argument.
   *	     2. This option argument has a binary type value argument.
   *	     (-1, -2) This option argument is optional.
   *
   */


GET_VALUE: procedure (option_num);


dcl  option_num fixed bin;				/* Number that identifies this option. */


	     option_code = option_codes (option_num);	/* Get code value for this option. */

	     if option_code = 0			/* Is there an accompanying argument value? */
	     then return;				/* No, nothing else to do. */

/* Get accompanying argument value. */
	     if argx = num_args			/* Is this the last argument? */
	     then if option_code < 0			/* Must there be a value argument? */
		then do;				/* No. */
		     if option_code = -1 then arg_ptr = null ();
		     else fixed_arg = 0;
		     return;
		end;
		else do;				/* Yes, value argument missing. */
		     ecode = error_table_$wrong_no_of_args;
		     call error_rtn_ (ecode, "assign_resource", "No value argument for ^a", option);
		     return;
		end;

	     argx = argx + 1;			/* Get the next argument. */
	     call get_argument (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call error_rtn_ (ecode, "assign_resource", "Error getting argument ^d", argx);
		return;
	     end;

	     if substr (argument, 1, 1) = "-"		/* Is next argument a control option? */
	     then if option_code < 0			/* Must there be a value argument? */
		then do;				/* No, two  control args in a row is OK. */
		     argx = argx - 1;		/* Process this argument over again. */
		     if option_code = -1 then arg_ptr = null ();
		     else fixed_arg = 0;
		     return;
		end;
		else do;				/* Yes, value argument is missing. */
		     ecode = error_table_$wrong_no_of_args;
		     call error_rtn_ (ecode, "assign_resource", "No value argument for ^a", option);
		     return;
		end;

	     if option_code = 1			/* Is argument value a string? */
	     then return;				/* Yes, no conversion necessary. */

/* Convert argument value to binary. */
	     fixed_arg = cv_dec_check_ (argument, badx);
	     if badx ^= 0				/* Argument contains non decimal characters. */
	     then do;
		ecode = error_table_$bad_arg;
		call error_rtn_ (ecode, "assign_resource", " ""^a"" is not a decimal number.", argument);
		return;
	     end;


	end GET_VALUE;

/*
   *
   *	This procedure prints information about one assigned device.
   *
   */


PRINT_DEVICE_INFO: procedure;

	     if (long_flag) | (^device_flag)
	     then call ioa_ ("Device ^a assigned", device_info.device_name);

	     if ^long_flag then return;		/* Does user want all available information? */

	     goto DTYPE_INFO (dtypex);		/* Other info depends upon device type. */


DTYPE_INFO (1):					/* TAPE */
	     call ioa_ ("Model^-=  ^d", device_info.model);
	     tape_info_ptr = device_info_ptr;		/* Use tape specific info. */
	     call ioa_ ("Tracks^-=  ^d", tape_info.tracks);
	     density_comment = "";			/* Clear density comment. */
	     do i = 1 to hbound (density_names, 1);	/* Test for each possiblle density. */
		if substr (tape_info.density, i, 1)
		then density_comment = density_comment || " " || density_names (i);
	     end;
	     call ioa_ ("Densities^-= ^a", density_comment);
	     speed_comment = "";
	     do i = 1 to hbound (speed_names, 1);	/* Test for each possible speed. */
		if substr (tape_info.speed, i, 1)
		then speed_comment = speed_comment || " " || speed_names (i);
	     end;
	     call ioa_ ("Speed^-= ^a", speed_comment);
	     return;


DTYPE_INFO (3):					/* CONSOLE */
	     call ioa_ ("Model^-=  ^a", console_models (device_info.model));
	     return;


DTYPE_INFO (4):					/* PRINTER */
	     call ioa_ ("Model^-=  ^d", device_info.model);
	     printer_info_ptr = device_info_ptr;	/* Use printer specific info. */
	     call ioa_ ("Train^-=  ^d", printer_info.print_train);
	     if printer_info.line_length = -1
	     then call ioa_ ("Line Len^-=  not specified");
	     else call ioa_ ("Line Len^-=  ^d", printer_info.line_length);
	     return;


DTYPE_INFO (2):					/* DISK */
DTYPE_INFO (5):					/* PUNCH */
DTYPE_INFO (6):					/* READER */
DTYPE_INFO (7):					/* SPECIAL */
	     call ioa_ ("Model^-=  ^d", device_info.model);
	     return;				/* No extra information for these device types. */


	end PRINT_DEVICE_INFO;

/*
   *
   *	This procedure is called to process one optional control argument.
   *	Many of the control arguments have an accompanying value argument.
   *	This value must be the next argument.  In this case we will process
   *	the value argument too.
   *
   */


PROCESS_ARG: procedure;


	     call get_argument (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call error_rtn_ (ecode, "assign_resource", "Error getting argument ^d", argx);
		return;
	     end;

	     option = argument;			/* Save option argument. */

	     do i = 1 to hbound (long_options, 1);	/* Look for valid option name. */
		if (option = brief_options (i)) |	/* Is it this brief name? */
		(option = long_options (i))		/* Or this long name? */
		then do;				/* Yes, one of them. */
		     call GET_VALUE (i);		/* Get value argument if any. */
		     if ecode ^= 0 then return;	/* Check for errors. */
		     goto OPTION (i);		/* Go process this option. */
		end;
	     end;

	     ecode = error_table_$badopt;		/* Option name not found. */
	     call error_rtn_ (ecode, "assign_resource", "^a", argument);
	     return;


OPTION (1):					/* "-dv" or "-device" */
	     device_info.device_name = argument;	/* Assign a specific device. */
	     device_flag = "1"b;
	     return;


OPTION (2):					/* "-lg" or "-long" */
               if active_fnc then do;			/* -lg isn't allowed in AF case		*/
	        ecode = error_table_$bad_arg;
	        call error_rtn_ (ecode, "assign_resource", "Control arg not allowed for the active function. ^a", argument);
	        end;

	     else long_flag = "1"b;			/* Return all info when device assigned. */
	     return;


OPTION (3):					/* "-com" or "-comment" */
	     comment = argument;			/* Save user's comment to operator. */
	     return;


OPTION (4):					/* "-model" */
	     device_info.model = fixed_arg;
	     return;


OPTION (5):					/* "-tk" or "-track" */
	     if (fixed_arg ^= 9) &			/* Validate value. */
	     (fixed_arg ^= 7)
	     then goto BAD_ARG;
	     tracks = fixed_arg;
	     return;


OPTION (6):					/* "-den" or "-density" */
	     do i = 1 to hbound (density_values, 1);	/* Look for a valid density value. */
		if fixed_arg = density_values (i)
		then do;				/* We found one. */
		     substr (density, i, 1) = "1"b;
		     return;
		end;
	     end;
	     goto BAD_ARG;				/* Invalid value. */


OPTION (7):					/* "-vol" or "-volume" */
	     volume_name = argument;
	     return;


OPTION (8):					/* "-tn" or "-train" */
	     print_train = fixed_arg;
	     return;


OPTION (9):					/* "-ll" or "-line_length" */
	     line_length = fixed_arg;
	     return;


OPTION (10):					/* "-sys" or "-system" */
	     system_flag = "1"b;			/* User wants to be a system process. */
	     return;


OPTION (11):					/* "-nb" or "-number" */
	     number = fixed_arg;			/* Number of similar devices to assign. */
	     if number > hbound (alist, 1)		/* Is number too large? */
	     then goto BAD_ARG;			/* Yes, error. */
	     return;


OPTION (12):					/* "-wt" or "-wait" */
	     wait_flag = "1"b;			/* Remember that user wants to wait. */
	     if (fixed_arg = 0) |			/* If no wait time specified. */
	     (fixed_arg > (24 * 60))			/* Or wait time greater tha allowed max? */
	     then max_num_waits = (24 * 60);		/* Use default of 24 hours. */
	     else max_num_waits = fixed_arg;		/* Use user's wait time. */
	     num_waits = 0;				/* Initialize actual number of waits. */
	     return;


OPTION (13):					/* "-speed" */
	     do i = 1 to hbound (speed_values, 1);	/* look for a valid speed value */
		if fixed_arg = speed_values (i) then do; /* found one */
		     substr (speed, i, 1) = "1"b;
		     return;
		end;
	     end;
	     goto BAD_ARG;


BAD_ARG:
	     ecode = error_table_$bad_arg;
	     call error_rtn_ (ecode, "assign_resource", " ""^a"" is invalid for option ^a", argument, option);


	end PROCESS_ARG;

     end assign_resource;




		    attach_lv.pl1                   11/04/82  1936.3rew 11/04/82  1606.5       57924



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


attach_lv: alv: procedure;

/*	This program is a command that may be called to attach a logical volume.
   *	Created on 04/07/76 by Bill Silver.
   *
   *	Its calling sequence is:
   *
   *	attach_lv  volume_name
   *
   *	volume_name	The name of the logical volume to be attached.
*/

/* Modified 6/82 by F. W. Martinson to check number of arguments */
/*		AUTOMATIC  DATA		*/

dcl 1 info_buffer like lv_info;			/* An input logical volume info buffer. */

dcl 1 wait_list,					/* Structure used to block. */
    2 num_chans fixed bin,				/* Number of event channels to wait for. */
    2 channel fixed bin (71);				/* The only channel we will use. */

dcl 1 event_data,					/* Event message structure, not used. */
    2 channel_id fixed bin (71),
    2 message fixed bin (71),
    2 sender bit (36),
    2 origin bit (36),
    2 data_ptr ptr;

dcl  arg_len fixed bin;				/* Length of an argument string. */
dcl  arg_ptr ptr;					/* Pointer to an argument string. */
dcl  ecode fixed bin (35);				/* error_table_ code. */
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  rcp_id bit (36) aligned;				/* RCP ID for this attach operation. */
dcl  statex fixed bin;				/* State of device assignment. */
dcl  volume_name char (32);				/* Volume name. */


/*		BASED  DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Used to reference argument string. */


/*		EXTERNAL ENTRIES CALLED	*/

dcl  cleanup condition;				/* Used to unassign if trouble. */

dcl (addr) builtin;

dcl (error_table_$noarg,
     error_table_$notacted,
     error_table_$too_many_args) fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  convert_ipc_code_ entry (fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  rcp_$attach_lv entry (ptr, fixed bin (71), bit (36) aligned, fixed bin (35));
dcl  rcp_$check_attach_lv entry (bit (36) aligned, ptr, fixed bin, fixed bin (35));
dcl  rcp_$detach_lv entry (bit (36) aligned, fixed bin (35));
						/* 	*/
%include rcp_lv_info;
/* 	*/
/*	Begin command:  attach_lv, alv
*/
	ecode,					/* Now initialize variables. */
	     wait_list.channel = 0;
	wait_list.num_chans = 1;

	lv_info_ptr = addr (info_buffer);		/* Set up volume info structure. */

	lv_info.version_num = rlvi_version_1;		/* Assume version. */
	lv_info.usage_time,				/* These fields not used yet. */
	     lv_info.wait_time = 0;
	lv_info.system_flag = "0"b;			/* System process concept not supported yet. */

	call GET_VOLUME_INFO;			/* Get volume name. */
	if ecode ^= 0 then return;

	lv_info.volume_name = volume_name;

	rcp_id = "0"b;				/* No RCP ID yet. */

	on cleanup begin;				/* If user quits detach logical volume. */
	     call CLEANUP;
	end;

	call ipc_$create_ev_chn (wait_list.channel, ecode);
	if ecode ^= 0				/* RCP needs an event channel. */
	then do;					/* But we don't have one. */
	     call convert_ipc_code_ (ecode);
	     call com_err_ (ecode, "attach_lv", "Error creating event channel.");
	     return;
	end;

	call rcp_$attach_lv (lv_info_ptr, wait_list.channel, rcp_id, ecode);
	if ecode ^= 0				/* Was attach started OK? */
	then do;					/* No. */
	     call com_err_ (ecode, "attach_lv", "Error attaching ^a", volume_name);
	     call CLEANUP;
	     return;
	end;

ATTACH_LOOP:					/* Loop until attachment completed. */
	call rcp_$check_attach_lv (rcp_id, lv_info_ptr, statex, ecode);

	goto STATE (statex);			/* Process current state of attachment. */

STATE (0):					/* Attachment completed OK. */
	rcp_id = "0"b;				/* Don't detach now. */
	call CLEANUP;				/* Cleanup event channel. */
	call ioa_ ("^a attached", volume_name);
	return;

STATE (1):					/* Short wait, block until wakeup comes. */
	call ipc_$block (addr (wait_list), addr (event_data), ecode);
	if ecode ^= 0				/* Error in blocking is bad. */
	then do;
	     call convert_ipc_code_ (ecode);
	     call com_err_ (ecode, "attach_lv", "Error waiting for attach.");
	     call CLEANUP;
	     return;
	end;
	goto ATTACH_LOOP;				/* Waked up, check attach again. */

STATE (2):					/* Long wait, don't support this yet. */
	ecode = error_table_$notacted;

STATE (3):					/* Fatal error. */
	call com_err_ (ecode, "attach_lv", "Error attaching ^a", volume_name);
	call CLEANUP;
	return;
						/* 	*/
CLEANUP:	procedure;

/*	This procedure is called when the attachment has been aborted.
   *	If we have an RCP ID we will try to detach the volume we are attaching.
   *	If we have created an event channel then we must delete it.
*/
	     if rcp_id ^= "0"b			/* If we have an RCP ID try to detach. */
	     then call rcp_$detach_lv (rcp_id, ecode);

	     if wait_list.channel = 0 then return;	/* Did we created an event channel? */

	     call ipc_$delete_ev_chn (wait_list.channel, ecode);
	     if ecode ^= 0
	     then do;
		call convert_ipc_code_ (ecode);
		call com_err_ (ecode, "attach_lv", "Deleting event channel.");
	     end;

	end CLEANUP;
						/* 	*/
GET_VOLUME_INFO: procedure;

/*	This procedure is called to get the volume name.
*/
	     call cu_$arg_count (num_args);		/* Get number of arguments. */

	     if num_args ^= 1 then do;		/* Is there a volume name argument. */
		if num_args = 0 then ecode = error_table_$noarg; /* No. */
		else ecode = error_table_$too_many_args;
		call com_err_ (ecode, "attach_lv", "One argument required");
		return;
	     end;

	     call cu_$arg_ptr (1, arg_ptr, arg_len, ecode); /* Get volume name argument. */
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "attach_lv", "Error getting volume name argument");
		return;
	     end;

	     volume_name = argument;			/* Save the volume name argument. */

	end GET_VOLUME_INFO;

     end attach_lv;




		    build_resource_desc_.pl1        08/14/86  1057.2rew 08/14/86  1048.9      378828



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



/****^  HISTORY COMMENTS:
  1) change(86-07-28,Hartogs), approve(86-07-28,MCR7463),
     audit(86-08-06,Lippard), install(86-08-14,MR12.0-1123):
     Make changes to disallow specifying less than 1 resource for reservation.
                                                   END HISTORY COMMENTS */

build_resource_desc_:
     proc (P_inargs, P_areap, P_cargp, P_rscp, P_cargidx, P_errmsg, P_code);

/* Written at some point or another by R.J.C. Kissel */
/* Last modified 06/17/81 by C. D. Tavares to make "" as an acs_path not be
   expanded to [wd]. */

dcl  P_inargs dim (*) char (*) varying;
dcl  error_table_$unimplemented_version
     fixed bin (35) external;

	P_rscp = null ();
	P_errmsg = "";
	P_code = error_table_$unimplemented_version;
	return;



/* Local Variables */

dcl  DUMB_acs_path char (168);			/* To pacify Tavares. */
dcl  acarg_idx fixed bin;				/* Index into the additional control arg array. */
dcl  apply_defaults bit (1) aligned;			/* True if defaults to be applied to resource_descriptions */
dcl  argument char (256) varying;
						/* Holds arguments to be processed. */
dcl  array_args bit (1);				/* True if the arguments are in the array, P_inargs. */
dcl  attr_type fixed bin;				/* 0-absolute, 1-relative, 2-multiple. */
dcl  carg_idx fixed bin;				/* Index into the resource description control arg array. */
dcl  cargs_given bit (1);				/* True if any control arguments have been given. */
dcl  code fixed bin (35);				/* System status code. */
dcl  resource_type char (32);				/* Used to get primary resource type. */
dcl  exists bit (1);				/* Indicates wheter or not the argument exists. */
dcl  item_idx fixed bin;				/* Index into resource_descriptions items. */
dcl  names_given bit (1);				/* True if any names of resources are given. */
dcl  number_given bit (1);				/* True if the "-nb" control arg is specified. */
dcl  num_of_rscs fixed bin;				/* The number of resources described by the caller. */
dcl  nvals fixed bin;				/* Number of values to skip index. */
dcl  reservation bit (1);				/* True if a reservation structure is needed. */

dcl 1 rsc_info aligned like resource_descriptions.item;
dcl  caller_area area (261129) based (P_areap);

/* Global Variables */

dcl  arg_idx fixed bin;				/* Get_Next_Arg..index of arg in command line. */
dcl  name_stack_ptr ptr;				/* Save_Name, Get_Name..storage pointer. */
dcl  name_tail_ptr ptr;				/* Save_Name, Get_Name..storage pointer. */
dcl  nargs fixed bin;				/* Get_Next_Arg..number of args in command line. */
dcl  rdp_stack_ptr ptr;				/* Save_Pointer, Get_Pointer..storage pointer. */
dcl  rdp_tail_ptr ptr;				/* Save_Pointer, Get_Pointer..storage pointer. */

/* Global Based Variables */

dcl 1 acargs aligned based (P_cargp),
    2 number fixed bin,
    2 arg (0b refer (acargs.number)),
      3 long_name char (32),
      3 short_name char (32),
      3 nvals fixed bin;

dcl  acarg_indicies (acargs.number) based (P_cargidx);

/* Global Constants */

dcl  C_rd_cargs (24) char (32) internal static options (constant) initial ("-acc",
						/*  1 */
     "-access_class",				/*  2 */
     "-acs_path",					/*  3 */
     "-alloc",					/*  4 */
     "-attr",					/*  5 */
     "-attributes",					/*  6 */
     "-charge_type",				/*  7 */
     "-com",					/*  8 */
     "-comment",					/*  9 */
     "-crgtp",					/* 10 */
     "-loc",					/* 11 */
     "-location",					/* 12 */
     "-lock",					/* 13 */
     "-nb",					/* 14 */
     "-number",					/* 15 */
     "-ow",					/* 16 */
     "-owner",					/* 17 */
     "-pacc",					/* 18 */
     "-pattr",					/* 19 */
     "-potential_access_class",			/* 20 */
     "-potential_attributes",				/* 21 */
     "-release_lock",				/* 22 */
     "-rll",					/* 23 */
     "-uid" /* 24 */);

/* Include Files */

	%include resource_control_desc;

/* External Entries */

dcl  absolute_pathname_$add_suffix
     entry (char (*), char (*), char (*), fixed bin (35));
dcl  convert_authorization_$from_string_range
     entry (bit (72) aligned dim (2), char (*), fixed bin (35));
dcl  cu_$arg_count_rel entry (fixed bin, ptr);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_rcp_attributes_$from_string
     entry (char (*), bit (72) dim (2) aligned, char (*) varying, fixed bin (35));
dcl  cv_rcp_attributes_$modify_rel
     entry (bit (72) dim (2) aligned, bit (72) dim (4) aligned, bit (72) dim (2) aligned);
dcl  cv_rcp_attributes_$from_string_rel
     entry (char (*), bit (72) dim (4) aligned, char (*) varying, fixed bin (35));
dcl  cv_rcp_attributes_$test_valid
     entry (char (*), bit (72) dim (2) aligned, fixed bin, fixed bin (35));
dcl  get_group_id_ entry () returns (char (32));
dcl  resource_info_$defaults
     entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  resource_info_$get_primary_type
     entry (char (*), char (*), fixed bin (35));

/* External Constants */

dcl  error_table_$badcall
     fixed bin (35) external;
dcl  error_table_$bad_index
     fixed bin (35) external;
dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$inconsistent
     fixed bin (35) external;
dcl  error_table_$rcp_attr_not_permitted
     fixed bin (35) external;
dcl  error_table_$rcp_bad_attributes
     fixed bin (35) external;
dcl  error_table_$bad_conversion
     fixed bin (35) external;
dcl  error_table_$noarg fixed bin (35) external;

/* Builtin Functions and Conditions */

dcl (convert, bit, divide, fixed, hbound, lbound, length, maxlength, null, rtrim, substr, unspec)
     builtin;

dcl (area, cleanup, conversion)
     condition;

from_arglist:
	entry (P_clinep, P_areap, P_cargp, P_rscp, P_apply_defaults, P_cargidx, P_errmsg, P_code);

dcl (
     P_clinep ptr,					/* Input  -- to caller's command line. */
     P_areap ptr,					/* Input  -- to caller's area. */
     P_cargp ptr,					/* Input  -- to additional control arg descriptions. */
     P_rscp ptr,					/* Output -- to resource_descriptions structure. */
     P_apply_defaults bit (1) aligned,			/* Input -- ON if defaults wanted in resource_descriptions */
     P_cargidx ptr,					/* Output -- to an array of indicies for the additional cargs. */
     P_errmsg char (*) varying,			/* Output -- descriptive error message. */
     P_code fixed bin (35)				/* Output -- standard status code. */
     ) parameter;

/*

   D_E_S_C_R_I_P_T_I_O_N_

   This subroutine takes a pointer to a command line and uses cu_$arg_ptr_rel
   to get individual arguments.  It parses the command line looking first at the
   additional control arguments, if any are specified, and then at the control
   arguments for a resource description.
   Resource description control arguments and non-control arguments are used
   to fill in a resource_descriptions structure.  This structure will be allocated
   in the caller supplied area and a pointer returned.
   If additional control arguments are found then the index of the argument
   in the command line is returned in the caller supplied array.  An error is recognized
   if there are not enough arguments left on the command line to supply the values
   required by the control argument.  Otherwise, these values are simply skipped
   and parsing continues.  It is the caller's responsibility to pick up and process
   these control arguments when control is returned to him.  A zero value for the
   index means that the corresponding control argument was not found.
   The returned error message may be used along with the error code in a call
   to com_err_ to output a meaningful error message.


   J_O_U_R_N_A_L_I_Z_A_T_I_O_N_

   1) Written 10/78 by R.J.C. Kissel.
   2) Modified 3/79 by R.J.C. Kissel to get and use the defaults in the RTDT.
   3) Modified 08/79 by C. D. Tavares to only apply defaults when required, not all the time.

*/











	call Initialize ();
	apply_defaults = P_apply_defaults;
	rdp_stack_ptr = null ();			/* These are only used by the Cleanup_Handler */
	rdp_tail_ptr = null ();			/*  for this entry point. */
	array_args = "0"b;
	reservation = "0"b;
	arg_idx = 0;

	call cu_$arg_count_rel (nargs, P_clinep);

	on cleanup
	     call Cleanup_Handler ();

	call Process_Resource_Spec ();

/*

   All the arguments have been successfully processed, now we will allocate
   the structure that the caller wants to have filled in.  We can do this because
   now we know the number of resources it must describe.  Then we will fill in
   the information we have found.
   Note that if the caller gave us a null area pointer then we are done and will
   just return.

*/

	call Fill_Resource_Desc ();

	P_rscp = resource_desc_ptr;
	P_errmsg = "";				/* Everything is all right. */
	P_code = 0;
	return;

reserve:
	entry (P_inargs, P_areap, P_cargp, P_rscp, P_resp, P_cargidx, P_errmsg, P_code);

dcl  P_resp ptr parameter;				/* Output -- to resource reservation structure. */

/*

   D_E_S_C_R_I_P_T_I_O_N_

   This subroutine perfors many of the same functions as the from_arglist
   entry point.  However, the arguments are taken from an input array
   rather than a command line.  Also, this entry must build a resource
   reservation structure, and it must handle multiple resource specifications
   separated by the -resource_type or -rsct control argument.


   J_O_U_R_N_A_L_I_Z_A_T_I_O_N_

   1) Written 12/78 by R.J.C. Kissel.
   2) Modified 3/79 by R.J.C. Kissel to get and use the defaults in the RTDT.

*/

/* Local Variables */

dcl  rdp ptr;					/* To the saved resource_descriptions structures. */
dcl  total_rscs fixed bin;				/* Total of num_of_rscs for each resource specification. */
dcl  mitem_idx fixed bin;				/* Item index for the master resource_description structure. */










	rdp_stack_ptr = null ();
	rdp_tail_ptr = null ();

	array_args = "1"b;				/* The arguments are in an array. */
	reservation = "1"b;				/* Multiple resource specifications are allowed. */
	arg_idx = 0;
	total_rscs = 0;

	nargs = hbound (P_inargs, 1);

	call Initialize ();				/* To close a small cleanup window. */
	apply_defaults = "0"b;
	on cleanup
	     call Cleanup_Handler ();

/*
   This loop processes all of the resource specifications in the resource
   description.  They are separated by the -resource_type or -rsct control
   argument which Process_Resource_Spec recognizes.  The arg_idx keeps
   track of how far we have gotten.  A pointer to the resource_descriptions
   structure for each specification is saved for later use.
*/

	do while (arg_idx < nargs);			/* arg_idx is controlled by Process_Resource_Spec. */
	     call Initialize ();
	     call Process_Resource_Spec ();
	     call Fill_Resource_Desc ();
	     call Save_Pointer (resource_desc_ptr);
	     total_rscs = total_rscs + num_of_rscs;
	end;

/*
   Now that we know everything we can allocate the final structures
   and fill them in from the saved information.
*/

	if P_areap ^= null ()
	then do;					/* Allocate stuff for the caller. */
	     Resource_count = total_rscs;

	     on area
		goto ERROR_area;
	     allocate resource_descriptions in (caller_area) set (resource_desc_ptr);
	     allocate reservation_description in (caller_area) set (resource_res_ptr);
	     revert area;

/* Now copy the information we have gathered. */

	     call Get_Pointer (rdp);
	     if rdp = null ()
	     then goto ERROR_badone;			/* There must be at least one at hhis point. */

	     mitem_idx = 1;

	     do while (rdp ^= null ());		/* Loop through all saved structures. */
		do item_idx = 1 to rdp -> resource_descriptions.n_items;
		     resource_descriptions.item (mitem_idx) = rdp -> resource_descriptions.item (item_idx);
		     mitem_idx = mitem_idx + 1;
		end;

		free rdp -> resource_descriptions;
		call Get_Pointer (rdp);
	     end;

/* Fill in the constant information in the two structures. */

	     resource_descriptions.version_no = resource_desc_version_1;
	     reservation_description.version_no = resource_res_version_1;
	     reservation_description.reserved_for = get_group_id_ ();
	     reservation_description.reserved_by = get_group_id_ ();
	     reservation_description.reservation_id = 0b;
	     reservation_description.group_starting_time = 0b;
	     reservation_description.asap_duration = 0b;
	     reservation_description.flags.auto_expire = "1"b;
	     reservation_description.flags.asap = "0"b;
	     reservation_description.flags.rel = "0"b;
	     reservation_description.flags.sec = "0"b;
	     reservation_description.reservation_group (*).starting_time = 0b;
	     reservation_description.reservation_group (*).duration = 0b;
	end;					/* Allocate stuff for the caller. */

	else do;					/* Caller wants nothing. */
	     resource_desc_ptr = null ();
	     resource_res_ptr = null ();
	end;
						/* Caller wants nothing. */
	P_rscp = resource_desc_ptr;
	P_resp = resource_res_ptr;

/*
   P_errmsg has already been initialized to the null string in Initialize.  We don't
   want to set it here because it may contain some auxillary information that is
   described in the comment in Process_Resource_Spec in the attribute processing section.
*/

	P_code = 0;
	return;

/*

   All error handling is done here.  There is a separate label for each possible
   error.  These are in the main program so that the subroutines can make non-local
   transfers out of the current environment and then return to the caller after
   building the error message.

*/

ERROR_acarg:
	P_errmsg = "After " || rtrim (acargs.arg (acarg_idx).long_name) || ".";
	P_code = error_table_$noarg;
	call Cleanup_Handler ();
	return;

ERROR_allocarg:
	P_errmsg = argument || "not on or off.";
	P_code = error_table_$badopt;
	call Cleanup_Handler ();
	return;

ERROR_area:
	P_errmsg = "Error allocating storage necessary for program operation.";
	P_code = error_table_$badcall;
	call Cleanup_Handler ();
	return;

ERROR_attr:
	P_errmsg = "Bad attribute specification: " || argument || ".";
	P_code = code;
	call Cleanup_Handler ();
	return;

ERROR_badarg:
	P_errmsg = argument;
	P_code = error_table_$badopt;
	call Cleanup_Handler ();
	return;

ERROR_badnb:
	P_errmsg = argument;
	P_code = error_table_$bad_conversion;
	call Cleanup_Handler ();
	return;

ERROR_badone:
	P_errmsg = "From build_resource_desc_.";
	P_code = error_table_$bad_index;
	call Cleanup_Handler ();
	return;

ERROR_cagiv:
	P_errmsg = "resource name " || argument || " appears after a control argument.";
	P_code = error_table_$badcall;
	call Cleanup_Handler ();
	return;

ERROR_defaults:
	P_errmsg = "Error obtaining defaults for " || rtrim (rsc_info.type) || ".";
	P_code = code;
	call Cleanup_Handler ();
	return;

ERROR_exterr:
	P_errmsg = "";				/* Error produced by an external call, just use code. */
	P_code = code;
	call Cleanup_Handler ();
	return;

ERROR_lownb:
          P_errmsg = "Number must be 1 or greater to be valid.";
	P_code = error_table_$bad_conversion;
	call Cleanup_Handler ();
	return;

ERROR_noarg:
	P_errmsg = "After " || argument;
	P_code = error_table_$noarg;
	call Cleanup_Handler ();
	return;

ERROR_noname:
	P_errmsg = "After -name.";
	P_code = error_table_$noarg;
	call Cleanup_Handler ();
	return;

ERROR_nonb:
	P_errmsg = "-number with explicit names.";
	P_code = error_table_$inconsistent;
	call Cleanup_Handler ();
	return;

ERROR_notype:
	P_errmsg = "A resource type must always be specified.";
	P_code = error_table_$badcall;
	call Cleanup_Handler ();
	return;

ERROR_pacc:
	P_errmsg = "Bad access bounds specification: " || argument || ".";
	P_code = code;
	call Cleanup_Handler ();
	return;

ERROR_pattr:
	P_errmsg = argument;
	P_code = code;
	call Cleanup_Handler ();
	return;

ERROR_prota:
	P_errmsg = """*"" not allowed in potential attributes.";
	P_code = error_table_$rcp_attr_not_permitted;
	call Cleanup_Handler ();
	return;

ERROR_type:
	P_errmsg = "Unrecognized resource type: " || argument || ".";
	P_code = code;
	call Cleanup_Handler ();
	return;

ERROR_uid:
	P_errmsg = argument;
	P_code = error_table_$bad_conversion;
	call Cleanup_Handler ();
	return;

%page;
Initialize:
	proc ();

/*

   All the local and global variables are initialized here, unless they are
   assigned to at their first use.

*/

	     argument = "";
	     num_of_rscs = 0b;
	     names_given = "0"b;
	     number_given = "0"b;
	     cargs_given = "0"b;
	     name_stack_ptr = null ();
	     name_tail_ptr = null ();
	     resource_desc_ptr = null ();
	     resource_res_ptr = null ();

	     unspec (rsc_info) = "0"b;

/*

   Now we will initialize all the cahracter strings in the structure to
   null string instead of zero bit strings.  This will make the output
   easier to read.

*/

	     rsc_info.type = "";
	     rsc_info.name = "";
	     rsc_info.owner = "";
	     rsc_info.acs_path = "";
	     rsc_info.location = "";
	     rsc_info.comment = "";
	     rsc_info.charge_type = "";

	end Initialize;

Process_Resource_Spec:
	proc ();

/*

   The resource type must be the first argument and must always be present.
   volume or a device.
   The -resource_type or -rsct control argument is optional and will
   be ignored.

*/

	     call Get_Next_Arg (argument, exists);	/* Get the type. */
	     if ^exists
	     then goto ERROR_notype;

	     if argument = "-resource_type" | argument = "-rsct"
	     then call Get_Next_Arg (argument, exists);

	     call resource_info_$get_primary_type ((argument), resource_type, code);
						/* Check the type. */
	     if code ^= 0
	     then goto ERROR_type;

	     rsc_info.type = resource_type;		/* use primary type */

/*

   Now process the rest of the arguments supplied by the caller.  If there are
   any names they must be first, before any control arguments.  Anything beginning
   with "-" unless it is preceded by "-name" or "-nm" is assumed to be a control
   argument, anything else is assumed to be a name.  A control argument is checked
   against the additional control argument array supplied by the caller first, and then
   against the known resource description control arguments.
   If this is a reservation then multiple resource types may appear
   separated by -resource_type or -rsct.  Therefore,  if "reservation" is
   true and one of these control arguments is found, we return to the
   caller because we have processed a complete resource specification.
   Notice that "arg_idx" points to the -resource_type or -rsct argument.

*/

	     call Get_Next_Arg (argument, exists);

	     do while (exists);			/* Loop through arguments. */

		if reservation & (argument = "-resource_type" | argument = "-rsct")
		then goto DONE;

		if substr (argument, 1, 1) ^= "-" | argument = "-name" | argument = "-nm"
		then do;				/* This is a name. */
		     if argument = "-name" | argument = "-nm"
		     then do;			/* Get the real name. */
			call Get_Next_Arg (argument, exists);
			if ^exists
			then goto ERROR_noname;
		     end;				/* Get the real name. */

		     if cargs_given
		     then goto ERROR_cagiv;		/* Any names must be before control args. */

		     call Save_Name (argument);

		     num_of_rscs = num_of_rscs + 1;
		     names_given = "1"b;
		end;				/* This is a name. */

		else if Is_Acarg (argument, acarg_idx)
		then do;				/* Look for additional cargs before cargs. */
		     cargs_given = "1"b;
		     acarg_indicies (acarg_idx) = arg_idx;
		     do nvals = 1 to acargs.arg (acarg_idx).nvals;
						/* Skip over values. */
			call Get_Next_Arg (argument, exists);
			if ^exists
			then goto ERROR_acarg;	/* Make sure they are there. */
		     end;				/* Skip over values. */
		end;				/* Look for additional cargs before cargs. */

		else if Is_Carg (argument, carg_idx)
		then do;				/* This is a resource description carg. */

		     if carg_idx < lbound (CARG, 1) | carg_idx > hbound (CARG, 1)
		     then goto ERROR_badone;		/* Program malfunction. */

		     cargs_given = "1"b;

		     goto CARG (carg_idx);		/* Essentially a case statement. */

CARG (2):
CARG (1):						/* -access_class, -acc */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     call convert_authorization_$from_string_range (rsc_info.aim_range, (argument), code);
		     if code ^= 0
		     then goto ERROR_pacc;
		     rsc_info.given.aim_range = "1"b;
		     goto ESAC;

CARG (3):						/* -acs_path */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     if argument = "" then
			rsc_info.acs_path = "";

		     else do;
			call absolute_pathname_$add_suffix
			     ((argument), "acs", DUMB_acs_path, code);
			if code ^= 0
			then goto ERROR_exterr;
			rsc_info.acs_path = DUMB_acs_path;
		     end;

		     rsc_info.given.acs_path = "1"b;
		     goto ESAC;

CARG (4):						/* -alloc */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     if argument = "on"
		     then rsc_info.user_alloc = "1"b;
		     else if argument = "off"
		     then rsc_info.user_alloc = "0"b;
		     else goto ERROR_allocarg;

		     rsc_info.given.user_alloc = "1"b;
		     goto ESAC;

CARG (6):
CARG (5):						/* -attributes, -attr */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     call cv_rcp_attributes_$from_string_rel ((rsc_info.type), rsc_info.desired_attributes, argument,
			code);
		     if code ^= 0
		     then goto ERROR_attr;

		     rsc_info.given.desired_attributes = "1"b;

/*
   Now we will do a kludgey thing.  In order that parse_resource_desc_ can know that
   the user specified attributes, we will set the status code for this resource to 1.
   This is necessary because currently either names or attributes
   are allowed but not both, and we will lose the information about what the user said
   because setting default attributes always says that attributes were given.  Finally,
   we need to know that attributes were given in rcp_reserve_ so we can do the right thing.
   This code can be eliminated when both names and attributes are allowed in a resource
   type specification.
*/

		     rsc_info.status_code = 1;
		     goto ESAC;

CARG (7):
CARG (10):					/* -charge_type, -crgtp */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     rsc_info.charge_type = argument;
		     rsc_info.given.charge_type = "1"b;
		     goto ESAC;

CARG (9):
CARG (8):						/* -comment, -com */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     rsc_info.comment = argument;
		     rsc_info.given.comment = "1"b;
		     goto ESAC;

CARG (12):
CARG (11):					/* -location, -loc */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     rsc_info.location = argument;
		     rsc_info.given.location = "1"b;
		     goto ESAC;

CARG (13):					/* -lock */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     if argument = "on"
		     then rsc_info.usage_lock = "1"b;

		     else if argument = "off"
		     then rsc_info.usage_lock = "0"b;

		     else goto ERROR_allocarg;

		     rsc_info.given.usage_lock = "1"b;
		     goto ESAC;

CARG (14):
CARG (15):					/* -number, -nb */
		     if names_given
		     then goto ERROR_nonb;

		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     on conversion
			goto ERROR_badnb;
		     if convert (num_of_rscs, argument) < 1 then goto ERROR_lownb;
		     num_of_rscs = num_of_rscs + convert (num_of_rscs, argument);
		     revert conversion;

		     number_given = "1"b;		/* For later use. */
		     goto ESAC;

CARG (16):
CARG (17):					/* -owner, -ow */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     rsc_info.owner = argument;
		     rsc_info.given.owner = "1"b;
		     goto ESAC;

CARG (18):
CARG (20):					/* -potential_access_class, -pacc */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     call convert_authorization_$from_string_range (rsc_info.potential_aim_range, (argument), code);
		     if code ^= 0
		     then goto ERROR_pacc;
		     rsc_info.given.potential_aim_range = "1"b;
		     goto ESAC;

CARG (19):
CARG (21):					/* -potential_attributes, -pattr */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

/*

   Convert the caller supplied attribute string, we will use rsc_info.attributes
   as temporary storage since it has the right dimensionality.  It will be cleaned
   up later.

*/

		     call cv_rcp_attributes_$from_string ((rsc_info.type), rsc_info.attributes, argument, code);
		     if code ^= 0
		     then goto ERROR_pattr;
						/*

						   Now test the second (protected attributes) string returned.  If any
						   "1" bits are present then the caller specified an "*" which is not allowed for
						   potential attributes.  Otherwise, we are only interested in the first (current
						   attributes) string.

						   */

		     if rsc_info.attributes (2)
		     then goto ERROR_prota;

/*

   Now test the attributes string to make sure it is absolute or multiple
   since that is what a potential attribute string must be.

*/

		     call cv_rcp_attributes_$test_valid ((rsc_info.type), rsc_info.attributes, attr_type, code);
		     if attr_type = 1		/* 1 is a relative attribute string. */
		     then code = error_table_$rcp_bad_attributes;

		     if code ^= 0
		     then goto ERROR_pattr;

		     rsc_info.potential_attributes = rsc_info.attributes (1);
		     rsc_info.attributes (*) = "0"b;	/* Clean up after ourselves. */
		     rsc_info.given.potential_attributes = "1"b;
		     goto ESAC;

CARG (22):
CARG (23):					/* -release_lock, -rll */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     if argument = "on"
		     then rsc_info.release_lock = "1"b;

		     else if argument = "off"
		     then rsc_info.release_lock = "0"b;

		     else goto ERROR_allocarg;

		     rsc_info.given.release_lock = "1"b;
		     goto ESAC;

CARG (24):					/* -uid */
		     call Get_Next_Arg (argument, exists);
		     if ^exists
		     then goto ERROR_noarg;

		     rsc_info.uid = bit (fixed (cv_oct_check_ ((argument), code), 36));
		     if code ^= 0
		     then goto ERROR_uid;

		     rsc_info.given.uid = "1"b;
		     goto ESAC;

ESAC:						/* End of the pseudo case statement. */
		end;				/* This is a resource description carg. */

		else goto ERROR_badarg;		/* Unrecognized argument. */

		call Get_Next_Arg (argument, exists);	/* Keep the loop going. */
	     end;					/* Loop through arguments. */

/*

   Now that everything is ok make some final checks and settings.  If
   neither the number of resources no the names of any resources have been
   specified then the default number of resources is one.  Also, if any names
   have been given then we can set the names given bit in rsc_info because
   it must be on for each item in the resource_descriptions structure.

*/

DONE:						/* Only called if reservation = "1"b and a -resource_type or -rsct argument is found. */
	     if ^names_given & ^number_given
	     then num_of_rscs = 1b;

	     rsc_info.given.name = names_given;

	end Process_Resource_Spec;

Fill_Resource_Desc:
	proc ();

	     if P_areap ^= null ()
	     then do;				/* Caller wants the structure. */
		Resource_count = num_of_rscs;

		on area
		     goto ERROR_area;
		allocate resource_descriptions in (caller_area) set (resource_desc_ptr);
		revert area;

/*

   Now set the constant information and defaults in the structure.  Do this by looping
   through the structure to set up each item.  If desired attributes are given,  they must be applied
   to the defaults in a special way.  Potential attributes are never a relative
   attribute string so defaults need not be used.  Note that n_items is already set by the
   allocation, and the type is set by setting the defaults.

*/

		do item_idx = lbound (resource_descriptions.item, 1) to hbound (resource_descriptions.item, 1) by 1;
						/* Set all items to null values. */

		     unspec (resource_descriptions.item (item_idx)) = "0"b;

		     resource_descriptions.item (item_idx).type = "";
		     resource_descriptions.item (item_idx).name = "";
		     resource_descriptions.item (item_idx).owner = "";
		     resource_descriptions.item (item_idx).acs_path = "";
		     resource_descriptions.item (item_idx).location = "";
		     resource_descriptions.item (item_idx).comment = "";
		     resource_descriptions.item (item_idx).charge_type = "";
		end;				/* Set all items to null values. */

		resource_descriptions.version_no = resource_desc_version_1;

		do item_idx = lbound (resource_descriptions.item, 1) to hbound (resource_descriptions.item, 1) by 1;
						/* Fill in each item. */

		     resource_descriptions.item (item_idx).type = rsc_info.type;

		     if rsc_info.given.uid
		     then resource_descriptions.item (item_idx).uid = rsc_info.uid;

		     if rsc_info.given.potential_attributes
		     then resource_descriptions.item (item_idx).potential_attributes = rsc_info.potential_attributes;

		     if rsc_info.given.desired_attributes
		     then do;			/* Apply these specially. */

/* Copy these for now to get them in the right form. */

			resource_descriptions.item (item_idx).attributes (1) =
			     resource_descriptions.item (item_idx).desired_attributes (1);
			resource_descriptions.item (item_idx).attributes (2) =
			     resource_descriptions.item (item_idx).desired_attributes (2);

			call cv_rcp_attributes_$modify_rel (resource_descriptions.item (item_idx).attributes (*),
			     rsc_info.desired_attributes, resource_descriptions.item (item_idx).attributes (*));

/* Now copy the results back where they belong. */

			resource_descriptions.item (item_idx).desired_attributes (1) =
			     resource_descriptions.item (item_idx).attributes (1);
			resource_descriptions.item (item_idx).desired_attributes (2) =
			     resource_descriptions.item (item_idx).attributes (2);
			resource_descriptions.item (item_idx).desired_attributes (3) = "0"b;
			resource_descriptions.item (item_idx).desired_attributes (4) = "0"b;

/* Now clean up our mess. */

			resource_descriptions.item (item_idx).attributes (*) = "0"b;
		     end;				/* Apply these specially. */

		     if rsc_info.given.potential_aim_range
		     then resource_descriptions.item (item_idx).potential_aim_range (*) =
			rsc_info.potential_aim_range (*);

		     if rsc_info.given.aim_range
		     then resource_descriptions.item (item_idx).aim_range (*) = rsc_info.aim_range (*);

		     if rsc_info.given.owner
		     then resource_descriptions.item (item_idx).owner = rsc_info.owner;

		     if rsc_info.given.acs_path
		     then resource_descriptions.item (item_idx).acs_path = rsc_info.acs_path;

		     if rsc_info.given.location
		     then resource_descriptions.item (item_idx).location = rsc_info.location;

		     if rsc_info.given.comment
		     then resource_descriptions.item (item_idx).comment = rsc_info.comment;

		     if rsc_info.given.charge_type
		     then resource_descriptions.item (item_idx).charge_type = rsc_info.charge_type;

		     if rsc_info.given.usage_lock
		     then resource_descriptions.item (item_idx).usage_lock = rsc_info.usage_lock;

		     if rsc_info.given.release_lock
		     then resource_descriptions.item (item_idx).release_lock = rsc_info.release_lock;

		     if rsc_info.given.user_alloc
		     then resource_descriptions.item (item_idx).user_alloc = rsc_info.user_alloc;

/*
   For now we will copy the given bits, although they really should be or'ed
   with the ones set by the defaults.  Also, we will always set the desired
   attributes bit on so that rcp_reserve_ can use the defaults.
*/

		     resource_descriptions.item (item_idx).given = rsc_info.given;

		     if names_given
		     then do;			/* Fill in the name. */
			call Get_Name (argument, exists);
			if ^exists
			then goto ERROR_badone;

			resource_descriptions.item (item_idx).name = argument;
			resource_descriptions.item (item_idx).given.name = "1"b;
		     end;				/* Fill in the name. */

		     else resource_descriptions.item (item_idx).name = "";

		     if apply_defaults then do;
			call resource_info_$defaults ((rsc_info.type), "", resource_desc_ptr, item_idx, code);
			if code ^= 0
			then goto ERROR_defaults;
		     end;

		end;				/* Fill in each item. */
	     end;					/* Caller wants the structure. */

	end Fill_Resource_Desc;

Get_Next_Arg:
	proc (P_arg, P_arg_exists);

dcl (
     P_arg char (*) varying,				/* Output -- the argument found. */
     P_arg_exists bit (1)				/* Output -- there was an argument to find. */
     ) parameter;

/*

   D_E_S_C_R_I_P_T_I_O_N_

   This internal procedure does everything necessary to obtain the next
   argument, either from the command line or an input array of character strings.
   Certain variables are declared globally in the main program which should be
   "own" variables for this procedure because of a deficiency in Multics PL1.

*/

/* Local Variables */

dcl  based_arg char (arg_len) based (arg_ptr);
dcl  arg_len fixed bin;
dcl  arg_ptr ptr;

	     arg_idx = arg_idx + 1;			/* We want the next one. */

	     if arg_idx > nargs
	     then do;				/* No more args. */
		arg_idx = arg_idx - 1;		/* Always point at a good argument, or 0. */
		P_arg_exists = "0"b;
						/* P_arg is left alone for error processing if necessary. */
	     end;					/* No more args. */

	     else do;				/* Get the next arg. */
		if reservation
		then do;				/* Argument in array. */
		     P_arg = P_inargs (arg_idx);
		     P_arg_exists = "1"b;
		end;				/* Argument in array. */

		else do;				/* Argument in command line. */
		     call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, P_clinep);
		     if code ^= 0
		     then goto ERROR_exterr;

		     if arg_len > maxlength (P_arg)
		     then ;			/* May want to log this sometime. */

		     P_arg = based_arg;
		     P_arg_exists = "1"b;
		end;				/* Argument in command line. */
	     end;					/* Get the next arg. */

	end Get_Next_Arg;

Save_Name:
	proc (P_name);

dcl  P_name char (*) varying parameter;
						/* Input  -- name to save. */

/*

   D_E_S_C_R_I_P_T_I_O_N_

   This internal subroutine saves character string arguments which are passed to it.
   It does so by allocating stroage and building a LIFO list of names.  Note that
   name_stack_ptr and name_tail_ptr are initialized in the main program to "null".

*/

/* Local Variables */

dcl  name_len fixed bin;				/* Length of the name to store. */
dcl  nip ptr;					/* Name item pointer. */
dcl 1 name_item aligned based,
    2 len fixed bin,
    2 name char (name_len refer (name_item.len)),
    2 next ptr;

	     name_len = length (P_name);

	     on area
		goto ERROR_area;
	     allocate name_item set (nip);
	     revert area;

	     nip -> name_item.name = P_name;
	     nip -> name_item.next = null ();

	     if name_stack_ptr = null ()
	     then name_stack_ptr = nip;		/* Only done the first time. */

	     if name_tail_ptr ^= null ()
	     then name_tail_ptr -> name_item.next = nip;

	     name_tail_ptr = nip;

	end Save_Name;

Get_Name:
	proc (P_name, P_name_exists);

dcl (
     P_name char (*) varying,				/* Output -- the next name in the list. */
     P_name_exists bit (1)				/* Output -- whether or not there is a name. */
     ) parameter;

/*

   D_E_S_C_R_I_P_T_I_O_N_

   This internal subroutine gets the next name from the LIFO list built by
   Save_Name.  It frees the list as it goes.  It also sets a flag to indicate
   whether or not a name was found.

*/

/* Local Variables */

dcl  nip ptr;					/* Name item pointer. */
dcl 1 name_item aligned based,
    2 len fixed bin,
    2 name char (0b refer (name_item.len)),
    2 next ptr;

	     if name_stack_ptr = null ()
	     then do;
		P_name = "";
		P_name_exists = "0"b;
	     end;

	     else do;
		nip = name_stack_ptr;
		P_name = nip -> name_item.name;
		P_name_exists = "1"b;
		name_stack_ptr = nip -> name_item.next;
		free nip -> name_item;
	     end;

	end Get_Name;

Save_Pointer:
	proc (P_ptr);

dcl  P_ptr ptr parameter;				/* Input  -- the pointer to be saved. */

/* Local Variables */

dcl  rip ptr;
dcl 1 rdp_item aligned based,
    2 next ptr,
    2 data ptr;

	     on area
		goto ERROR_area;
	     allocate rdp_item set (rip);
	     revert area;

	     rip -> rdp_item.data = P_ptr;
	     rip -> rdp_item.next = null ();

	     if rdp_stack_ptr = null ()
	     then rdp_stack_ptr = rip;		/* Only done the first time. */

	     if rdp_tail_ptr ^= null ()
	     then rdp_tail_ptr -> rdp_item.next = rip;

	     rdp_tail_ptr = rip;

	end Save_Pointer;

Get_Pointer:
	proc (P_ptr);

dcl  P_ptr ptr parameter;				/* Output -- the next pointer in the list. */

/* Local Variables */

dcl  rip ptr;
dcl 1 rdp_item aligned based,
    2 next ptr,
    2 data ptr;

	     if rdp_stack_ptr = null ()
	     then P_ptr = null ();

	     else do;
		rip = rdp_stack_ptr;
		P_ptr = rip -> rdp_item.data;
		rdp_stack_ptr = rip -> rdp_item.next;
		free rip -> rdp_item;
	     end;

	end Get_Pointer;

Is_Acarg:
	proc (P_arg, P_idx) returns (bit (1));

dcl (
     P_arg char (*) varying,				/* Input  -- argument to check. */
     P_idx fixed bin				/* Output -- index in caller supplied array. */
     ) parameter;

/*

   D_E_S_C_R_I_P_T_I_O_N_

   This internal subroutine checks th input argument against a caller
   supplied array of additional control argument names.  The index in the caller
   supplied array is returned as well as an indication as to whether or not a match
   was found.
   At some time we may wany to require that the input array be alphabetical
   and do a binary search.

*/

/* Local Variables */

dcl  idx fixed bin;
dcl  found bit (1);
dcl  num_args fixed bin;

	     if P_cargp = null | P_cargidx = null ()
	     then do;				/* No array given. */
		P_idx = 0;
		found = "0"b;
	     end;					/* No array given. */

	     else do;				/* Array given. */
		num_args = P_cargp -> acargs.number;

		do idx = 1 to num_args
			while (P_arg ^= P_cargp -> acargs.arg (idx).long_name
			& P_arg ^= P_cargp -> acargs.arg (idx).short_name);
		end;

		if idx > num_args
		then do;				/* Did not find it. */
		     P_idx = 0;
		     found = "0"b;
		end;				/* Did not find it. */

		else do;				/* Found it. */
		     P_idx = idx;
		     found = "1"b;
		end;				/* Found it. */
	     end;					/* Array given. */

	     return (found);

	end Is_Acarg;

Is_Carg:
	proc (P_arg, P_idx) returns (bit (1));

dcl (
     P_arg char (*) varying,				/* Input  -- argument to check. */
     P_idx fixed bin				/* Output -- index into the known cargs. */
     ) parameter;

/*

   D_E_S_C_R_I_P_T_I_O_N_

   This internal subroutine checks the input argument against the known list
   of resource description control arguments.  The index in this list is returned
   as well as an indication of whether or not a match was found in the list.
   A binary search will be used so the list of control arguments must always
   be alphabetical.  Notice that by definition of arrays, lbound, and hbound that
   the loop is executed at least once.

*/

/* Local Variables */

dcl  lb fixed bin;					/* Lower bound. */
dcl  mp fixed bin;					/* Midpoint. */
dcl  ub fixed bin;					/* Upper bound. */

	     lb = lbound (C_rd_cargs, 1);		/* Lower bound for the search. */
	     ub = hbound (C_rd_cargs, 1);		/* Upper bound for the search. */

	     do while (lb <= ub);
		mp = divide (lb + ub, 2, 17);		/* Midpoint for the search. */

		if P_arg = C_rd_cargs (mp)
		then do;
		     P_idx = mp;			/* Found. */
		     return ("1"b);
		end;

		if P_arg < C_rd_cargs (mp)
		then ub = mp - 1;
		else lb = mp + 1;
	     end;

	     P_idx = 0;				/* Not found. */
	     return ("0"b);

	end Is_Carg;

Cleanup_Handler:
	proc ();

/*

   D_E_S_C_R_I_P_T_I_O_N_

   This internal procedure cleans up before returning to the caller.
   Essentially, this just means checking for any storage which may have been
   allocated and freeing it if necessary.  It is not called if the program
   terminates normally.
   Any error codes or conditions produced by this subroutine will either be
   handled immediately or ignored as appropriate.

*/

dcl  nip ptr;					/* Name item pointer. */
dcl 1 name_item aligned based,
    2 len fixed bin,
    2 name char (0b refer (name_item.len)),
    2 next ptr;

dcl  rip ptr;					/* Rdp item pointer. */
dcl 1 rdp_item aligned based,
    2 next ptr,
    2 data ptr;

dcl  rdp ptr;


	     if resource_desc_ptr ^= null ()
	     then free resource_descriptions in (caller_area);

	     if resource_res_ptr ^= null ()
	     then free reservation_description in (caller_area);

	     do while (name_stack_ptr ^= null ());
		nip = name_stack_ptr;
		name_stack_ptr = nip -> name_item.next;
		free nip -> name_item;
	     end;

	     do while (rdp_stack_ptr ^= null ());
		rip = rdp_stack_ptr;
		rdp_stack_ptr = rip -> rdp_item.next;
		rdp = rip -> rdp_item.data;
		if rdp ^= null ()
		then free rdp -> resource_descriptions in (caller_area);
		free rip -> rdp_item;
	     end;

/* Set the output parameters except for the error message and code. */

	     if reservation
	     then P_resp = null ();
	     P_rscp = null ();
	     if P_cargidx ^= null () & P_cargp ^= null ()
	     then acarg_indicies = 0b;		/* An array assignment. */

	end Cleanup_Handler;

     end build_resource_desc_;




		    cancel_resource.pl1             11/04/82  1936.3rew 11/04/82  1619.1       32562



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


cancel_resource:
cnr:
     proc ();

/*
   D_E_S_C_R_I_P_T_I_O_N_

   This command takes a reservation identifier and cancels the
   reservation to which it belongs.  This command just implements the
   user interface.  It calls resource_control_$cancel_id to do the
   actual work.


   J_O_U_R_N_A_L_I_Z_A_T_I_O_N_

   1) Written 11/78 by R.J.C. Kissel.
*/

/* Local Variables */

dcl  code fixed bin (35);
dcl  nargs fixed bin;
dcl  arg_ptr ptr;
dcl  arg_len fixed bin;
dcl  arg char (arg_len) based (arg_ptr);
dcl  arg_count fixed bin;
dcl  res_id char (res_id_len) based (res_id_ptr);
dcl  res_id_len fixed bin;
dcl  res_id_ptr ptr;
dcl  system bit (1) aligned;

/* External Entries */

dcl  resource_control_$cancel_id_string
     entry (char (*), char (*), bit (1) aligned, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);

/* External Constants */

dcl  error_table_$badopt fixed bin (35) external;

	call cu_$arg_count (nargs);
	if nargs > 3 | nargs < 2
	then goto ERROR_usage;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0
	then goto ERROR_arg;

	system = "0"b;

	if nargs = 2
	then do;					/* Only "-id res_id". */
	     if arg = "-id"
	     then do;
		call cu_$arg_ptr (2, arg_ptr, arg_len, code);
		if code ^= 0
		then goto ERROR_arg;
		res_id_len = arg_len;
		res_id_ptr = arg_ptr;
	     end;

	     else goto ERROR_carg;
	end;					/* Only "-id res_id". */

	else do;					/* Either "-priv -id res_id" or "-id res_id -priv". */
	     if arg = "-priv"
	     then do;
		system = "1"b;
		arg_count = 2;
	     end;

	     else if arg = "-id"
	     then do;
		call cu_$arg_ptr (2, arg_ptr, arg_len, code);
		if code ^= 0
		then goto ERROR_arg;

		arg_count = 3;
		res_id_len = arg_len;
		res_id_ptr = arg_ptr;
	     end;

	     else goto ERROR_carg;

	     call cu_$arg_ptr (arg_count, arg_ptr, arg_len, code);
	     if code ^= 0
	     then goto ERROR_arg;

	     if arg_count = 3
	     then do;				/* Must be "-priv". */
		if arg = "-priv"
		then system = "1"b;
		else goto ERROR_carg;
	     end;					/* Must be "-priv". */

	     else do;				/* Must be "-id res_id". */
		if arg = "-id"
		then do;
		     call cu_$arg_ptr (3, arg_ptr, arg_len, code);
		     if code ^= 0
		     then goto ERROR_arg;

		     res_id_len = arg_len;
		     res_id_ptr = arg_ptr;
		end;

		else goto ERROR_carg;
	     end;					/* Must be "-id res_id". */
	end;					/* Either "-priv -id res_id" or "-id res_id -priv". */

	call resource_control_$cancel_id_string (res_id, "", system, code);
	if code ^= 0
	then goto ERROR_cancel;
	return;

/*
   Error handling code.
*/

ERROR_arg:
	call com_err_ (code, "cancel_resource");
	return;

ERROR_cancel:
	call com_err_ (code, "cancel_resource", "Unable to cancel reservation ^a.", res_id);
	return;

ERROR_carg:
	call com_err_ (error_table_$badopt, "cancel_resource", "^a", arg);
	return;

ERROR_usage:
	call com_err_ (0b, "cancel_resource", "Usage: cnr -id reservation_id {-priv}");
	return;

     end cancel_resource;




		    detach_lv.pl1                   11/04/82  1936.3rew 11/04/82  1606.6       46647



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


detach_lv: dlv: procedure;

/*	This program is a command that may be called to detach a logical volume.
   *	Created on 04/08/76 by Bill Silver.
   *	Modified on 12/09/78 by Michael R. Jordan for version 3 list info.
   *	Modified on 05/03/82 by J. Bongiovanni for version 4 list info.
   *
   *	demoun, dmt  volume
   *
   *	volume	Specifies the name of the logical volume or volumes to be detached.
   *		A user may detach all logical volumes attached for his/her
   *		process by specifying:
   *				"all"
   *		A user may detach one logical volume by specifying its volume name.
*/

/*		AUTOMATIC  DATA		*/

dcl  pointers (1) ptr;				/* Pointer array for temp segment manager. */

dcl  arg_len fixed bin;				/* Length of an argument string. */
dcl  arg_ptr ptr;					/* Pointer to an argument string. */
dcl  ecode fixed bin (35);				/* error_table_ code. */
dcl  i fixed bin;
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  num_detached fixed bin;				/* Number of volumes detached. */
dcl  seg_size fixed bin (19);				/* Max size of temp segment. */
dcl  volume_name char (32);				/* Name of volume to be detached. */


/*		BASED  DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Used to reference argument string. */


/*		EXTERNAL ENTRIES CALLED	*/

dcl  cleanup condition;

dcl (addr, null) builtin;

dcl  error_table_$noarg fixed bin (35) external;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  get_temp_segments_ entry (char (*), (1) ptr, fixed bin (35));
dcl  hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl  rcp_$copy_list entry (ptr, fixed bin (19), fixed bin (35));
dcl  rcp_$detach_lv entry (bit (36) aligned, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), (1) ptr, fixed bin (35));
						/* 	*/
%include rcp_list_info;
/* 	*/
/*	Begin command:  detach_lv
*/
	ecode,					/* Initialize. */
	     num_detached = 0;
	volume_name = " ";

	call cu_$arg_count (num_args);		/* Total number of command arguments. */

	if num_args < 1				/* Was any volume specified? */
	then do;					/* No, no argument. */
	     call com_err_ (error_table_$noarg, "detach_lv", "No volume specified.");
	     return;
	end;

	call cu_$arg_ptr (1, arg_ptr, arg_len, ecode);	/* Get volume name. */
	if ecode ^= 0
	then do;
	     call com_err_ (ecode, "detach_lv", "Error getting volume name argument.");
	     return;
	end;

	volume_name = argument;			/* Remember volume name. */

/*	User wants to detach one or more logical volumes from her/his process.
   *	Get temporary segment for RCP list info structure.
   *	Set up cleanup handler to release temp segment.
*/
	pointers (1) = null ();
	on cleanup begin;
	     if pointers (1) ^= null ()
	     then call release_temp_segments_ ("detach_lv", pointers, ecode);
	end;

	call get_temp_segments_ ("detach_lv", pointers, ecode);
	if ecode ^= 0				/* Unable to get temporary working segment? */
	then do;					/* Yes. */
	     call com_err_ (ecode, "detach_lv", "Error getting temporary segment");
	     goto RETURN;
	end;

	call hcs_$get_max_length_seg (pointers (1), seg_size, ecode);
	if ecode ^= 0				/* We need max size of temp segment. */
	then do;
	     call com_err_ (ecode, "detach_lv", "Error getting max seg length of temp segment");
	     goto RETURN;
	end;

	rli_ptr = pointers (1);			/* Temp segment used for RCP info. */
	rli.version_num = rli_version_4;

	call rcp_$copy_list (rli_ptr, seg_size, ecode);
	if ecode ^= 0				/* Error copying process's RCP info? */
	then do;					/* Yes. */
	     call com_err_ (ecode, "detach_lv", "Error copying RCP info");
	     goto RETURN;
	end;

	do i = 1 to rli.head.num_lv;			/* Look at each attached logical volume. */
	     lv_ptr = addr (rli.lvs (i));		/* Get pointer to lv attach entry. */
	     if (volume_name = "all") |		/* Detaching all lvs? */
	     (volume_name = lv.volume_name)		/* Or this lv? */
	     then do;				/* Yes, detach this logical volume. */
		num_detached = num_detached + 1;
		call rcp_$detach_lv (lv.rcp_id, ecode);
		if ecode ^= 0
		then call com_err_ (ecode, "detach_lv", "Error detaching ^a", lv.volume_name);
	     end;
	end;

	if num_detached = 0				/* Did we detach any volumes? */
	then if volume_name = "lv"			/* No. */
	     then call com_err_ (0, "detach_lv", "No logical volumes attached");
	     else call com_err_ (0, "detach_lv", "Logical volume ^a not attached", volume_name);

RETURN:
	call release_temp_segments_ ("detach_lv", pointers, ecode);
	if ecode ^= 0
	then call com_err_ (ecode, "detach_lv", "Error releasing temp segment");

	return;

     end detach_lv;




		    interpret_resource_desc_.pl1    04/09/85  1354.6rew 04/08/85  1026.9       90954



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

/* Written and never journalized, God knows when (probably by Tavares). */
/* Modified April 1985 by Chris Jones to not print AIM range of free resources. */

interpret_resource_desc_: proc (resource_desc_ptr, nth, callername, rst_control, called_as_af, return_string, code);

dcl  nth fixed bin parameter,
     called_as_af bit (1) aligned parameter,
     return_string char (*) varying parameter,
     callername char (*) parameter,
     code fixed bin (35) parameter;

dcl  SYSTEM_HIGH bit (72) aligned;

%include resource_control_desc;
%include rst_control;

dcl 1 itemx based (itemptr) aligned like resource_descriptions.item,
     itemptr pointer;

dcl (ioa_$rsnnl, ioa_, ioa_$nnl, com_err_, active_fnc_err_) ext entry options (variable);

dcl (i, j) fixed bin,
    (first, last) fixed bin,
     saved_code fixed bin (35),
     acc (2) char (256),
    (want_acc, want_pacc) bit (1) aligned,
     error_table_$unimplemented_version ext fixed bin (35) static,
     pacc (2) char (256),
     temp_atts (2) bit (72) aligned,
     attstring char (512) varying;

dcl  mode_strings (8) char (4) varying static options (constant) initial
    ("null", "w", "e", "ew", "r", "rw", "re", "rew");

dcl  convert_authorization_$to_string ext entry (bit (72) aligned, char (*), fixed bin (35)),
     convert_authorization_$from_string ext entry (bit (72) aligned, char (*), fixed bin (35)),
     cv_rcp_attributes_$to_string ext entry (char (*) aligned, (2) bit (72) aligned, char (*) varying, fixed bin (35)),
     cv_rcp_attributes_$to_string_rel ext entry (char (*) aligned, (4) bit (72) aligned, char (*) varying, fixed bin (35));

	saved_code = 0;

	if resource_descriptions.version_no ^= resource_desc_version_1 then do;
	     code = error_table_$unimplemented_version;
	     return;
	end;

	call convert_authorization_$from_string (SYSTEM_HIGH, "system_high", code);
	if code ^= 0 then call err (code, "converting system_high");

	if nth = 0 then do;
	     first = 1;
	     last = resource_descriptions.n_items;
	end;
	else first, last = nth;

	do i = first to last;

	     itemptr = addr (resource_descriptions.item (i));

	     if rst_control.name
	     | rst_control.default
	     | rst_control.any_given_item
	     | (first ^= last) then
		call ioa_ ("Resource: ^a ^a^[^; (not by name)^]",
		itemx.type, itemx.name, itemx.given.name);

	     if (rst_control.uid
	     | (itemx.given.uid & rst_control.any_given_item)) then
		if called_as_af then
		     call ioa_$rsnnl ("^w", return_string, 0, itemx.uid);
		else call ioa_ ("Unique ID:^-^w", itemx.uid);

	     if (rst_control.potential_attributes
	     | (itemx.given.potential_attributes & rst_control.any_given_item)) then do;
		unspec (temp_atts) = ""b;
		temp_atts (1) = itemx.potential_attributes;
		call cv_rcp_attributes_$to_string (itemx.type, temp_atts, attstring, code);
		if code ^= 0 then call err (code, "Potential attributes");

		else if called_as_af then return_string = attstring;
		else call ioa_ ("Potential Attributes:^/^2-^a", attstring);
	     end;

	     if rst_control.attributes then do;
		call cv_rcp_attributes_$to_string (itemx.type, itemx.attributes (*), attstring, code);
		if code ^= 0 then call err (code, "Attributes");

		else if called_as_af then return_string = attstring;
		else call ioa_ ("Attributes:^-^a", attstring);
	     end;

	     if (rst_control.desired_attributes
	     | (itemx.given.desired_attributes & rst_control.any_given_item)) then do;
		call cv_rcp_attributes_$to_string_rel (itemx.type, itemx.desired_attributes (*), attstring, code);
		if code ^= 0 then call err (code, "Desired attributes");
		else if called_as_af then return_string = attstring;
		else call ioa_ ("Desired attributes:^-^a", attstring);
	     end;

	     if (rst_control.owner
	     | (itemx.given.owner & rst_control.any_given_item)) then
		if called_as_af then return_string = rtrim (itemx.owner, " ");
		else call ioa_ ("Owner:^2-^a", itemx.owner);

	     if (rst_control.acs_path
	     | (itemx.given.acs_path & rst_control.any_given_item)) then
		if called_as_af then
		     if itemx.acs_path = "" then return_string = """""";
		     else return_string = rtrim (itemx.acs_path, " ");
		else call ioa_ ("ACS Pathname:^-^[none^;^a^]", (itemx.acs_path = ""), itemx.acs_path);

	     want_pacc = (rst_control.potential_aim_range
		| (itemx.given.potential_aim_range & rst_control.any_given_item));
	     want_acc = (rst_control.aim_range
		| (itemx.given.aim_range & rst_control.any_given_item));

	     if want_pacc | want_acc then do;

		do j = 1 to 2;
		     code = 0;
		     if itemx.potential_aim_range (j) = ""b then pacc (j) = "system_low";
		     else if itemx.potential_aim_range (j) = SYSTEM_HIGH then pacc (j) = "system_high";
		     else call convert_authorization_$to_string (itemx.potential_aim_range (j), pacc (j), code);
		     if want_pacc then
			if code ^= 0 then do;
			     call err (code, "Potential AIM range");
			     want_pacc = ""b;
			end;

		     code = 0;
		     if itemx.aim_range (j) = ""b then acc (j) = "system_low";
		     else if itemx.aim_range (j) = SYSTEM_HIGH then acc (j) = "system_high";
		     else call convert_authorization_$to_string (itemx.aim_range (j), acc (j), code);
		     if want_acc then
			if code ^= 0 then do;
			     call err (code, "AIM range");
			     want_acc = ""b;
			end;
		end;

		if want_pacc then
		     if called_as_af then
			if pacc (1) = pacc (2) then return_string = rtrim (pacc (1), " ");
			else return_string = rtrim (pacc (1), " ") || "; " || rtrim (pacc (2), " ");
		     else call ioa_ ("Potential AIM ^[Class:^/^2-^a^;Range:^/^2-^a : ^a", (pacc (1) = pacc (2)), pacc);

		if want_acc then
		     if called_as_af then
			if acc (1) = acc (2) then return_string = rtrim (acc (1), " ");
			else return_string = rtrim (acc (1), " ") || "; " || rtrim (acc (2), " ");
		     else if itemx.owner ^= "free" then
			call ioa_ ("AIM ^[Class:^-^a^;Range:^-^a : ^a^]", (acc (1) = acc (2)), acc);
	     end;

	     if (rst_control.location
	     | (itemx.given.location & rst_control.any_given_item)) then
		if called_as_af then return_string = """" || rtrim (itemx.location, " ") || """";
		else call ioa_ ("Location:^2-^[""""^;^a^]", (itemx.location = ""), itemx.location);

	     if (rst_control.comment
	     | (itemx.given.comment & rst_control.any_given_item)
	     | (itemx.comment ^= "" & rst_control.default)) then
		if called_as_af then return_string = """" || rtrim (itemx.comment, " ") || """";
		else call ioa_ ("Comment:^2-^[""""^;^a^]", (itemx.comment = ""), itemx.comment);

	     if (rst_control.charge_type
	     | (itemx.given.charge_type & rst_control.any_given_item)) then
		if called_as_af then return_string = """" || rtrim (itemx.charge_type, " ") || """";
		else call ioa_ ("Charge type:^-^[""""^;^a^]", (itemx.charge_type = ""), itemx.charge_type);

	     if rst_control.mode then
		if called_as_af then return_string = mode_strings (binary (itemx.rew) + 1);
		else call ioa_ ("Mode:^2-^a", mode_strings (binary (itemx.rew) + 1));

	     if (rst_control.usage_lock
	     | (itemx.given.usage_lock & rst_control.any_given_item)
	     | (itemx.usage_lock & rst_control.default)) then
		if called_as_af then
		     if itemx.usage_lock then return_string = "true";
		     else return_string = "false";
		else call ioa_ ("Usage Lock:^-^[on^;off^]", itemx.usage_lock);

	     if (rst_control.release_lock
	     | (itemx.given.release_lock & rst_control.any_given_item)
	     | (itemx.release_lock & rst_control.default)) then
		if called_as_af then
		     if itemx.release_lock then return_string = "true";
		     else return_string = "false";
		else call ioa_ ("Release Lock:^-^[on^;off^]", itemx.release_lock);

	     if (rst_control.awaiting_clear
	     | (itemx.awaiting_clear & rst_control.default)) then
		if called_as_af then
		     if itemx.awaiting_clear then return_string = "true";
		     else return_string = "false";
		else call ioa_ ("Awaiting Clear:^-^[yes^;no^]", itemx.awaiting_clear);

	     if (rst_control.user_alloc
	     | (itemx.given.user_alloc & rst_control.any_given_item)
	     | rst_control.default) then
		if called_as_af then
		     if itemx.user_alloc then return_string = "true";
		     else return_string = "false";
		else call ioa_ ("Allocation state:^-^[allocated^;free^]", itemx.user_alloc);

	     if rst_control.given_flags then do;
		call ioa_ ("Given flags:");
		if itemx.given.name then call ioa_ ("^-name");
		if itemx.given.uid then call ioa_ ("^-uid");
		if itemx.given.potential_attributes then call ioa_ ("^-potential_attributes");
		if itemx.given.desired_attributes then call ioa_ ("^-desired_attributes");
		if itemx.given.potential_aim_range then call ioa_ ("^-potential_aim_range");
		if itemx.given.owner then call ioa_ ("^-owner");
		if itemx.given.acs_path then call ioa_ ("^-acs_path");
		if itemx.given.location then call ioa_ ("^-location");
		if itemx.given.comment then call ioa_ ("^-comment");
		if itemx.given.charge_type then call ioa_ ("^-charge_type");
		if itemx.given.usage_lock then call ioa_ ("^-usage_lock");
		if itemx.given.release_lock then call ioa_ ("^-release_lock");
		if itemx.given.user_alloc then call ioa_ ("^-alloc");
	     end;

	     if i ^= last then call ioa_ ("");
	end;

	code = saved_code;
	return;

err:	proc (code, reason);

dcl  code fixed bin (35) parameter,
     reason char (*) parameter;

	     if called_as_af then call active_fnc_err_ (code, callername, reason);
	     else call com_err_ (code, callername, reason);

	     if called_as_af then return_string = "";
	     saved_code = code;
	end err;

     end interpret_resource_desc_;




		    list_resource_types.pl1         11/04/82  1936.3rew 11/04/82  1619.2       58500



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


list_resource_types: lrt: proc;

/* This command lists all known resource types in >sc1>rtdt. */
/* Written 03/28/78 by C. D. Tavares */
/* Modified 8/81 by M.R. Jordan to fix bugs in control argument processing. */
%page;
/*		*** CONSTANTS ***			*/

dcl  SYSDIR char (168) static initial (">system_control_1");
dcl  SYSENT char (32) static initial ("rtdt") options (constant);

/*		*** AUTOMATIC ***			*/

dcl  al fixed bin;
dcl  alp pointer;
dcl  ap pointer;
dcl  attribute_string char (512) varying;
dcl  bc fixed bin (24);
dcl  code fixed bin (35);
dcl  dirname char (168);
dcl  ename char (32);
dcl  header_sw bit (1)aligned;
dcl  i fixed bin;
dcl  j fixed bin;
dcl  junk fixed bin;
dcl  long_sw bit (1) aligned;
dcl  n_names_to_match fixed bin;
dcl  nargs fixed bin;
dcl  syn_found bit (1) aligned;
dcl  temp_atts (2) bit (72) aligned;

/*		*** BASED ***			*/

dcl  arg based (ap) char (al);

/*		*** ERROR CODES ***			*/

dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$name_not_found fixed bin (35) ext;
dcl  error_table_$unimplemented_version fixed bin (35) ext;

/*		*** EXTERNAL ENTRIES ***		*/

dcl  com_err_ ext entry options (variable);
dcl  cu_$arg_count ext entry (fixed bin);
dcl  cu_$arg_list_ptr ext entry (pointer);
dcl  cu_$arg_ptr_rel ext entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer);
dcl  cv_rcp_attributes_$to_string_given_rtde ext entry (pointer, (2) bit (72) aligned, char (*) varying, fixed bin (35));
dcl  expand_pathname_$add_suffix ext entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin, pointer, fixed bin (35));
dcl  hcs_$terminate_noname ext entry (pointer, fixed bin (35));
dcl  ioa_ ext entry options (variable);

/*		*** BUILTIN FUNCTIONS ***		*/
/*			 &			*/
/*		   *** CONDITIONS ***		*/

dcl  index builtin;
dcl  length builtin;
dcl  null builtin;
dcl  pointer builtin;
dcl  reverse builtin;
dcl  substr builtin;

dcl  cleanup condition;
%page;
%include rtdt;
%page;
	rtdtp = null ();

	call cu_$arg_list_ptr (alp);
	call cu_$arg_count (nargs);

	begin;


dcl  matchnames (nargs) char (32);


	     dirname = SYSDIR;
	     ename = SYSENT;

	     header_sw = "1"b;
	     long_sw = "0"b;
	     n_names_to_match = 0;

	     do i = 1 to nargs;
		call cu_$arg_ptr_rel (i, ap, al, code, alp);
		if code ^= 0 then call crump (code, "obtaining arguments");

		if substr (arg, 1, 1) = "-" then do;
		     if arg = "-lg" | arg = "-long" then long_sw = "1"b;

		     else if arg = "-pn" | arg = "-pathname" then do;
			i = i + 1;
			call cu_$arg_ptr_rel (i, ap, al, code, alp);
			if code ^= 0 then call crump (code, "No pathname supplied.");

			call expand_pathname_$add_suffix (arg, "rtdt", dirname, ename, code);
			if code ^= 0 then call crump (code, arg);
		     end;

		     else if arg = "-nhe" | arg = "-no_header" then header_sw = "0"b;

		     else call crump (error_table_$badopt, arg);
		end;

		else do;
		     n_names_to_match = n_names_to_match + 1;
		     matchnames (n_names_to_match) = arg;
		end;
	     end;

	     on cleanup call clean_up;

/* ------------------------- */

clean_up:	     proc;


		if rtdtp ^= null ()
		then call hcs_$terminate_noname (rtdtp, 0);

		return;


	     end clean_up;

/* ------------------------- */

	     call hcs_$initiate_count (dirname, ename, "", bc, 0, rtdtp, code);
	     if rtdtp = null then
		if ename = "rtdt.rtdt" then do;
		     ename = "rtdt";
		     call hcs_$initiate_count (dirname, ename, "", bc, 0, rtdtp, code);
		end;
	     if rtdtp = null then call crump (code, "^a>^a");

	     if (rtdt.version ^= RTDT_version_2) & (rtdt.version ^= RTDT_version_3) then
		call crump (error_table_$unimplemented_version, "^a>^a");

	     if header_sw then
		call ioa_ (" Type^-Name^[^2-Attributes^]^/", long_sw);

	     do junk = 1, 2 to 2 while (syn_found);

		syn_found = ""b;

		do rtdep = pointer (rtdt.first_resource, rtdt.rtdt_area)
			repeat (pointer (rtde.next_resource, rtdt.rtdt_area))
			while (rtdep ^= null);

		     if rtde.valid then do;

			do i = 1 to n_names_to_match while (matchnames (i) ^= rtde.name);
			end;

			if n_names_to_match = 0 | i <= n_names_to_match then do;

			     if i > 0 then matchnames (i) = "";

			     call ioa_ ("^[Volume^;Device^]^-^a^[  (synonym for ^a)^;^]", rtde.is_volume, rtde.name,
				rtde.is_synonym, rtde.syn_to);

			     if (long_sw & ^rtde.is_synonym) then do;

				temp_atts (1) = rtde.attributes_valid;
				temp_atts (2) = ""b;
				call cv_rcp_attributes_$to_string_given_rtde (rtdep, temp_atts, attribute_string, code);
				if code ^= 0 then call crump (code, "While getting attributes for " || rtde.name);

				do j = 1 by 1 while (attribute_string ^= "");
				     call ioa_ ("^- ^[^;  ^]^a", (j = 1), knockoff_60_ch (attribute_string));
				end;
			     end;

			     if rtde.is_synonym then if n_names_to_match > 0 then do;
				     matchnames (i) = rtde.syn_to;
				     syn_found = "1"b;
				end;

			end;
		     end;
		end;
	     end;

	     do i = 1 to n_names_to_match;
		if matchnames (i) ^= "" then
		     call com_err_ (error_table_$name_not_found, "list_resource_types", "^a", matchnames (i));
	     end;
	     call clean_up;

	     return;
	     
knockoff_60_ch: proc (string) returns (char (60) varying);

dcl  string char (512) varying parameter;

dcl  i fixed bin,
     temp char (60) varying;

		if length (string) <= 60 then do;
		     temp = string;
		     string = "";
		     return (temp);
		end;

		i = 61 - index (reverse (substr (string, 1, 60)), ",");
		temp = substr (string, 1, i);
		string = substr (string, i+1);

		return (temp);
	     end knockoff_60_ch;
	     
crump:	     proc (code, reason);

dcl  code fixed bin (35) parameter,
     reason char (*) parameter;

		call com_err_ (code, "list_resource_types", reason, dirname, ename);
		call clean_up;
		goto return_hard;
	     end crump;

	end;					/* begin block */

return_hard:
	return;

     end list_resource_types;




		    list_resources.pl1              07/16/87  1349.5r   07/15/87  1547.4      304335



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-06-02,Rauschelbach), approve(87-07-07,MCR7728),
     audit(87-07-08,Farley), install(87-07-15,MR12.1-1040):
     A seperate error message was added for -awaiting_clear without a -type
     argument instead of the same message as -acquisitions without -type.
                                                   END HISTORY COMMENTS */


/* format: indattr,inddcls,dclind5,idind30,struclvlind5,ifthenstmt,ifthendo,^inditerdo,^indnoniterend,case,^tree,^indproc,^indend,^delnl,^insnl,comcol81,indcom,linecom,^indcomtxt */

list_resources: lr: procedure;

	/*	This program is a command that may be called to list the resources that
   *	have been assigned to or mounted by the calling process by RCP.
   *	Created on 01/07/75 by Bill Silver.
   *	Changed on 04/08/76 by Bill Silver for "-lv" option and to use temp
   *		segments.
   *	Changed on 05/24/78 by Michael R. Jordan for tape_drive/disk_drive
   *		changes.
   *	Changed on 10/31/78 by C. D. Tavares to add -acquisitions portion and
   *		change -attachments to -mounts.
   *	Changed on 11/18/78 by M. R. Jordan for -reservations and speed
   *		qualifier for tapes.
   *	Changed on 05/10/79 by CDT to add -awaiting_clear control arg.
   *	Modified 831218 to call request_id_... BIM
   *	Modified 831220 to correctly list console types... -E. A. Ranzenbach
   *
   * 	(-type | -tp)	This option specifies that all of the devices of
   *			this type are to be listed.  It value argument
   *			must be the name of the device type to be
   *			listed.
   *	(-dv  | -device)	Specifies that a specific device is to be
   *			listed.  Its value argument must be the name of
   *			the device.  RCP will list information about
   *			only this one device.
   *	(-lg  | -long)	This command option specifies that the user
   *			wants all of the information known about the
   *			assignment or mount.  This option argument
   *			is not followed by a value argument.
   *	(-lv  | -logical_volumes)
   *			Specifies that only attached logical volumes are
   *			to be listed.
   *	(-resv | -reservations)
   *			Specifies that only reservations are to be
   *			listed.
   *	(-asm | -assignments)
   *			Specifies that only device assignments are to be
   *			listed.
   *	(-mts | -mounts)	Specifies that only mounts are to be listed.
   *	(-atm | -attachments) 	 (as above, kept for compatibility.)
   *	(-acq | -acquisitions)
   *			Specifies that only owned resources are to be
   *			listed.
   *	(-user userid)	Specifies that user or project's acquisitions
   *	(-awaiting_clear)	Specifies those resources awaiting manual
   *			clearing.
   */

	/* 	AUTOMATIC  DATA		*/

	dcl  alp			     pointer;			/* pointer to arg list */
	dcl  arg_len		     fixed bin;			/* Length of an argument string. */
	dcl  arg_ptr		     ptr;				/* Pointer to an argument string. */
	dcl  argx			     fixed bin;			/* Number of the current argument. */
	dcl  awaiting_clear		     bit (1) initial (""b);		/* ON if wants list of resources awaiting clear */
	dcl  called_as_af		     bit (1) aligned;		/* O if called as active function */
	dcl  cu_arg_ptr_entry	     entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer) variable;
	dcl  density_comment	     char (30) varying;		/* Used to print density capabilities. */
	dcl  density_ptr		     ptr;				/* Pointer to density characteristics. */
	dcl  device_name		     char (32);			/* Device name. */
	dcl  resource_type		     char (32);			/* Device type. */
	dcl  dtypex		     fixed bin;			/* Device type index. */
	dcl  vtypex		     fixed bin;			/* Volume type index */
	dcl  typex		     fixed bin;			/* scratch variable */
	dcl  ecode		     fixed bin (35);		/* error_table_ code. */
	dcl  (i, k)		     fixed bin;
	dcl  is_volume		     bit (1) aligned;
	dcl  list_index		     fixed bin;			/* 0 => all,  1 => type,  2 => device. */
	dcl  listed_flag		     bit (1);			/* ON => something has been listed. */
	dcl  long_flag		     bit (1);			/* ON => user wants all available information. */
	dcl  num_args		     fixed bin;			/* Number of command arguments. */
	dcl  num_listed		     fixed bin;			/* Number of entries actually listed. */
	dcl  option		     char (32);			/* Command option string. */
	dcl  option_code		     fixed bin;			/* 0 => none,  1 => string,  2 => binary. */
	dcl  rcp_list_copied	     bit (1) initial (""b);		/* if on, don't recopy it */
	dcl  request_control	     bit (36);			/* one bit for each control arg */
	dcl  return_argp		     pointer;			/* points to af return arg */
	dcl  return_argl		     fixed bin (21);		/* length of same */
	dcl  seconds		     fixed bin;			/* Max IOI time-out intraval. */
	dcl  seg_size		     fixed bin (19);		/* Size of temp segment. */
	dcl  speed_comment		     char (30) varying;		/* Used to print speed capabilities. */
	dcl  speed_ptr		     ptr;				/* Pointer to speed qualifier for tape drives. */
	dcl  temp_seg_ptr		     ptr;				/* for temp segment namager. */
	dcl  time_string		     char (24);			/* Used to list state time. */
	dcl  user_id		     char (32);			/* for acquisition section */

	/* 	BASED  DATA		*/

	dcl  argument		     char (arg_len) based (arg_ptr);	/* Used to reference argument string. */

	dcl  based_density		     bit (5) based (density_ptr) aligned;

	dcl  based_speed		     bit (3) based (speed_ptr) aligned;

	dcl  return_arg		     char (return_argl) varying based (return_argp);


	/* 	INTERNAL STATIC DATA	*/

	dcl  1 static_option_data	     (1:11) internal static options (constant),
		2 brief_options	     char (16) initial		/* Brief form of command options. */
				     ("-tp", "-dv", "-lg", "-asm", "-mts", "-lv", "-acq", "-user", "-atm",
				     "-resv", "-awaiting_clear"),
		2 long_options	     char (19) initial		/* Long  form of command options. */
				     ("-type", "-device", "-long", "-assignments", "-mounts",
				     "-logical_volumes", "-acquisitions", "-user", "-attachments",
				     "-reservations", "-awaiting_clear"),
		2 option_codes	     fixed bin initial
				     (1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0),
		2 af_usage_allowed	     bit (1) aligned initial
				     ("1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b);

	dcl  (Unset		     initial ("000000"b),
	     Default		     initial ("111101"b),
	     Assignments		     initial ("010000"b),
	     Mounts		     initial ("001000"b),
	     Logical_volumes	     initial ("000100"b),
	     Acquisitions		     initial ("000010"b),
	     Reservations		     initial ("000001"b)) bit (36) static options (constant);

	dcl  operation_states	     (5) char (12)			/* Assignment and mounting states. */
				     internal static init ("assigning", "assigning", "mounting", "mounting", "mounted");

	dcl  density_names		     (5) char (5) varying		/* Used to print device density characteristics. */
				     internal static init ("200 ", "556 ", "800 ", "1600 ", "6250 ");

	dcl  console_model_names	     (3) char (4)			/* Operator's console model names. */
				     internal static init ("EMC", "EMC", "LCC");
	dcl  console_models		     (3) fixed bin (17) internal static init (6001, 6004, 6601);

	dcl  speed_names		     (3) char (4)			/* Tape drive speed names. */
				     internal static init ("75 ", "125 ", "200 ");

	dcl  registry_dir		     char (168) static initial (">system_control_1>rcp");

	/* 	EXTERNAL ENTRIES CALLED	*/

	dcl  cleanup		     condition;			/* Used to release temp segment. */

	dcl  (addr, after, before, clock, hbound, length, max, null, rtrim, substr, unspec) builtin;

	dcl  (error_table_$badcall,
	     error_table_$badopt,
	     error_table_$inconsistent,
	     error_table_$not_act_fnc,
	     error_table_$odd_no_of_args,
	     error_table_$resource_type_inappropriate,
	     error_table_$wrong_no_of_args) fixed bin (35) external;

	dcl  (com_err_, active_fnc_err_)   entry options (variable);
	dcl  cu_$af_return_arg	     entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
	dcl  (cu_$arg_ptr_rel, cu_$af_arg_ptr_rel) entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
	dcl  cu_$arg_list_ptr	     ext entry (pointer);
	dcl  date_time_		     entry (fixed bin (71), char (*));
	dcl  ioa_			     entry options (variable);
	dcl  hcs_$get_max_length_seg	     entry (ptr, fixed bin (19), fixed bin (35));
	dcl  get_temp_segment_	     entry (char (*), ptr, fixed bin (35));
	dcl  release_temp_segment_	     entry (char (*), ptr, fixed bin (35));
	dcl  rcp_$copy_list		     entry (ptr, fixed bin (19), fixed bin (35));
	dcl  resource_info_$get_rtypex     entry (char (*), char (*), fixed bin, bit (1) aligned, fixed bin (35));

%include rcp_list_info;

	/* list_resources: */

	temp_seg_ptr = null;
	ecode,							/* Initialize. */
	     list_index = 0;					/* 0 => all devices of all types. */
	dtypex, vtypex, typex = 0;
	request_control = Unset;
	user_id = "";						/* default is myself */
	resource_type = "";

	long_flag = "0"b;						/* Default = minimum of information. */

	call cu_$af_return_arg (num_args, return_argp, return_argl, ecode);	/* Get total number of arguments. */
	if ecode = error_table_$not_act_fnc then do;
		called_as_af = ""b;
		cu_arg_ptr_entry = cu_$arg_ptr_rel;
	     end;
	else if ecode ^= 0 then do;
		call active_fnc_err_ (ecode, "list_resources", "Obtaining argument information.");
		if return_argp ^= null then return_arg = "";
		return;
	     end;
	else do;
		called_as_af = "1"b;
		cu_arg_ptr_entry = cu_$af_arg_ptr_rel;
	     end;

	call cu_$arg_list_ptr (alp);

	do argx = 1 to num_args;					/* Process each argument. */
	     call PROCESS_ARG;					/* Most will be processed in pairs. */
	     if ecode ^= 0 then return;				/* If error, abort */
	end;

	if request_control = Unset then request_control = Default;

	if called_as_af then					/* was more than one option specified? */
	     if after (request_control, "1"b) ^= ""b then do;
		     call active_fnc_err_ (error_table_$inconsistent, "list_resources",
			"More than one category of information requested in active function mode.");
		     return_arg = "";
		end;


	/*  Now that we have valid arguments, get a work segment.  Then call RCP
   to get the information about the resources associated with this process. */

	on cleanup begin;						/* Cleanup handler for temp seg releasing. */
		if temp_seg_ptr ^= null () then
		     call release_temp_segment_ ("list_resources", temp_seg_ptr, ecode);
	     end;

	call GET_TEMP_SEG;						/* Get temporary working segment. */
	if ecode ^= 0 then return;


	/* Now process the requests. */

	listed_flag = ""b;

	/* List assignments. */

	if (request_control & Assignments) ^= "0"b then do;
		call COPY_RCP_LIST;

		if (rli.head.num_dassign ^= 0)			/* if device assignments */
		     | (request_control ^= Default) then do;		/* or not default case */
			listed_flag = "1"b;				/* Something will be listed. */
			call ioa_ ("Device Assignments");
			call LIST_DASSIGN;				/* List all device assignments. */
		     end;
	     end;

	/* List mounts. */

	if (request_control & Mounts) ^= "0"b then do;
		call COPY_RCP_LIST;

		if (rli.head.num_attach ^= 0)				/* if device mounts */
		     | (request_control ^= Default) then do;		/* or not default case */
			listed_flag = "1"b;				/* Something will be listed. */
			call ioa_ ("Mounts");
			call LIST_MOUNTS;				/* List all device assignments. */
		     end;
	     end;

	/* List logical volumes. */

	if (request_control & Logical_volumes) ^= "0"b then do;
		call COPY_RCP_LIST;

		if (rli.head.num_lv ^= 0)				/* if logical volumes */
		     | (request_control ^= Default) then do;		/* or not default case */
			listed_flag = "1"b;				/* Something will be listed. */
			call ioa_ ("Logical Volumes");
			call LIST_LV;				/* List all device assignments. */
		     end;
	     end;


	/* List reservations. */

	if (request_control & Reservations) ^= "0"b then do;
		call COPY_RCP_LIST;

		if (rli.head.num_device_resv + rli.head.num_vol_resv ^= 0)	/* if reservations */
		     | (request_control ^= Default) then do;		/* or not default case */
			listed_flag = "1"b;				/* Something will be listed. */
			call ioa_ ("Resource Reservations");
			call LIST_RESERVATIONS;
		     end;
	     end;

	/* List acquisitions. */

	if (request_control & Acquisitions) ^= "0"b then do;

		if request_control ^= Acquisitions then			/* other things too */
		     call ioa_ ("Resource Acquisitions");
		listed_flag = "1"b;					/* Something will be listed. */
		call LIST_ACQUISITIONS;
	     end;


	if ^listed_flag then					/* Did we list anything? */
	     call ioa_ ("list_resources: No resources selected.");		/* No. */

RETURN:	if temp_seg_ptr ^= null then
	     call release_temp_segment_ ("list_resources", temp_seg_ptr, ecode);
	return;

PROCESS_ARG: procedure;

	/* This procedure is called to process one option argument.  Many of these
   options have an accompanying value argument.  This value must be the next
   argument.  In this case we will process the value argument too.  */

	call cu_arg_ptr_entry (argx, arg_ptr, arg_len, ecode, alp);
	if ecode ^= 0
	then call crump (ecode, "while obtaining arguments.");

	option = argument;						/* Save option argument. */
	do i = 1 to hbound (long_options, 1);				/* Look for valid option name. */
	     if (option = brief_options (i)) |				/* Is it this brief name? */
		(option = long_options (i))				/* Or this long name? */
	     then do;						/* Yes, one of them. */
		     if called_as_af then
			if ^af_usage_allowed (i) then do;
				call active_fnc_err_ (error_table_$badcall, "list_resources",
				     "^a not available in active function mode.", option);
				return_arg = "";
				return;
			     end;

		     call GET_VALUE (i);				/* Get value argument if any. */
		     if ecode ^= 0					/* Check for errors. */
		     then return;
		     goto OPTION (i);				/* Go process this option. */
		end;
	end;

	call crump (error_table_$badopt, option);			/* Option name not found. */
	return;

OPTION (1):							/* "-tp" or "-type" */
	list_index = max (1, list_index);				/* 1 => list all devices of this type. */

	dtypex, vtypex = 0;
	call resource_info_$get_rtypex (argument, resource_type, typex, is_volume, ecode);
	if ecode ^= 0 then
	     call crump (ecode, argument);

	if is_volume then vtypex = typex;
	else dtypex = typex;
	return;

OPTION (2):							/* "-dv" or "-device" */
	list_index = 2;						/* 2 => list only this one device. */
	device_name = argument;					/* Get device name. */
	return;
OPTION (3):							/* "-lg" or "-long" */
	long_flag = "1"b;						/* User wants all available information. */
	return;
OPTION (4):							/* "-asm" or "-assignments" */
	request_control = request_control | Assignments;			/* User wants device assignments. */
	return;
OPTION (9):							/* "-atm" or "-attachments" */
	call ioa_ ("list_resources:  Warning-- -mounts (-mts) should be used rather than -attachments (-atm).");
OPTION (5):							/* "-mts" or "-mounts" */
	request_control = request_control | Mounts;
	return;
OPTION (6):							/* "-lv" or "-logical_volumes" */
	request_control = request_control | Logical_volumes;		/* User wants attached logical volumes. */
	return;

OPTION (7):							/* "-acq" or "-acquisitions" */
	request_control = request_control | Acquisitions;
	return;

OPTION (8):							/* "-user" */
	if awaiting_clear then
	     call crump (error_table_$inconsistent, "-awaiting_clear and -user");

	user_id = argument;
	return;

OPTION (10):							/* "-reservations" or "-resv" */
	request_control = request_control | Reservations;
	return;

OPTION (11):							/* "-awaiting_clear" */
	request_control = request_control | Acquisitions;
	if user_id ^= "" then
	     call crump (error_table_$inconsistent, "-awaiting_clear and -user.");

	user_id = "*.*";
	awaiting_clear = "1"b;
	return;

     end PROCESS_ARG;

GET_VALUE: procedure (option_num);

	/* This procedure is called to get any value argument associated with this option.
   Processing of the value argument depends upon the option code value associated
   with this option.  The option code values are:
   0.	This option argument has no accompanying value argument.
   1.	This option argument has a string type value argument. */

	dcl  option_num		     fixed bin;			/* Number that identifies this option. */

	option_code = option_codes (option_num);			/* Get code value for this option. */

	if option_code = 0						/* Is there an accompanying argument value? */
	then return;						/* No, nothing else to do. */

	/* Get accompanying argument value. */

	if argx = num_args then					/* Is this the last argument? */
	     call crump (error_table_$odd_no_of_args, "No value argument for " || option);

	argx = argx + 1;						/* Get the next argument. */
	call cu_arg_ptr_entry (argx, arg_ptr, arg_len, ecode, alp);
	if ecode ^= 0 then
	     call crump (ecode, "while obtaining arguments.");

	if substr (argument, 1, 1) = "-" then				/* Is next argument a control option? */
	     call crump (error_table_$wrong_no_of_args, "No value argument for " || option);

     end GET_VALUE;

COPY_RCP_LIST: proc;

	if rcp_list_copied then return;

	rli.head.version_num = rli_version_4;				/* Tell RCP version we are working with. */
	call rcp_$copy_list (rli_ptr, seg_size, ecode);
	if ecode ^= 0 then
	     call crump (ecode, "Error copying RCP list information.");

	rcp_list_copied = "1"b;

	return;

     end COPY_RCP_LIST;

LIST_DASSIGN: procedure;

	/* This procedure is called to list device assignments.  The device
   assignments that will be listed depend upon the list_index variable.
   We will list the assignments of all devices, all devices of a specified
   type, or one specific device. */

	num_listed = 0;
	goto DASSIGN (list_index);					/* Decide which device assignments to list. */

DASSIGN (0):							/* List all device assignments. */
	if rli.head.num_dassign = 0					/* Any devices assigned? */
	then do;							/* No. */
		call ioa_ ("No devices assigned.");
		return;
	     end;
	if long_flag						/* If in long mode tell how many. */
	then if rli.head.num_dassign = 1
	     then call ioa_ ("1 device assigned");
	     else call ioa_ ("^d devices assigned", rli.head.num_dassign);
	do i = 1 to rli.head.num_dassign;				/* Process each device assignment block. */
	     dassign_ptr = addr (rli.dassigns (i));
	     call LIST_DASSIGNMENT;					/* List each one. */
	end;
	return;

DASSIGN (1):							/* All device assignments of specified type. */
	if is_volume then
	     call crump (error_table_$resource_type_inappropriate, rtrim (resource_type) || " is not a device type.");
	do i = 1 to rli.head.num_dassign;				/* Look at each device assignment block. */
	     dassign_ptr = addr (rli.dassigns (i));
	     if dtypex = dassign.dtypex				/* Is this the device type specified? */
	     then call LIST_DASSIGNMENT;				/* Yes, list this device assignment. */
	end;
	if num_listed = 0						/* Did we find any for this device type? */
	then call ioa_ ("^5xNo ^a type devices assigned.", resource_type);
	return;

DASSIGN (2):							/* List specific device assignment. */
	if is_volume then
	     call crump (error_table_$resource_type_inappropriate, rtrim (resource_type) || " is not a device type.");
	do i = 1 to rli.head.num_dassign;				/* Look through all device assignments. */
	     dassign_ptr = addr (rli.dassigns (i));
	     if device_name = dassign.device_name
	     then do;						/* We found the device. */
		     call LIST_DASSIGNMENT;				/* List its assignment info. */
		     return;					/* No need to look further. */
		end;
	end;
	call ioa_ ("^5xDevice ^a is not assigned", device_name);

     end LIST_DASSIGN;

LIST_MOUNTS: procedure;

	/* This procedure is called to list mounts.  The mounts that will be listed
   depend upon the list_index variable.  We will list info on all devices, all
   devices of a specified type, or one specific device.  */

	num_listed = 0;
	goto MOUNTS (list_index);					/* Decide which mounts to list. */

MOUNTS (0):							/* List all mounts. */
	if rli.head.num_attach = 0					/* Any mounts? */
	then do;							/* No. */
		call ioa_ ("No mounts.");
		return;
	     end;
	if long_flag then						/* If in long mode tell how many. */
	     call ioa_ ("^d mount^[s^;^]", rli.head.num_attach,
		(rli.head.num_attach = 1));

	do i = 1 to rli.head.num_attach;				/* Process each mount. */
	     attach_ptr = addr (rli.attaches (i));
	     call LIST_SINGLE_MOUNT;					/* List each one. */
	end;
	return;

MOUNTS (1):							/* All mounts of specified type. */
	if is_volume then
	     call crump (error_table_$resource_type_inappropriate, rtrim (resource_type) || " is not a device type.");
	do i = 1 to rli.head.num_attach;				/* Look at each mount block. */
	     attach_ptr = addr (rli.attaches (i));
	     if dtypex = attach.dtypex				/* Is this the device type specified? */
	     then call LIST_SINGLE_MOUNT;
	end;
	if num_listed = 0						/* Did we find any for this device type? */
	then call ioa_ ("^5xNo ^a type devices mounted.", resource_type);
	return;

MOUNTS (2):							/* List specific device mount. */
	if is_volume then
	     call crump (error_table_$resource_type_inappropriate, rtrim (resource_type) || " is not a device type.");
	do i = 1 to rli.head.num_attach;				/* Look through all mounts. */
	     attach_ptr = addr (rli.attaches (i));
	     if device_name = dassign.device_name
	     then do;						/* We found the device. */
		     call LIST_SINGLE_MOUNT;				/* List its mount info. */
		     return;
		end;
	end;
	call ioa_ ("^5xDevice ^a is not mounted.", device_name);

     end LIST_MOUNTS;

LIST_LV: procedure;

	/* This procedure is called to list attached logical volumes.
   All logical volumes attached for the calling process will be listed. */

	if rli.head.num_lv = 0					/* Any logical volumes attached? */
	then do;							/* No. */
		call ioa_ ("No logical volumes");
		return;
	     end;

	do i = 1 to rli.num_lv;					/* List all attached logical volumes. */
	     lv_ptr = addr (rli.lvs (i));				/* Get pointer to lv info. */
	     call ioa_ ("^5x^a", lv.volume_name);
	     if long_flag						/* Does user want more info? */
	     then do;						/* Yes. */
		     call ioa_ ("^-State^-=  attached");
		     call date_time_ (lv.state_time, time_string);
		     call ioa_ ("^-Time^-=  ^a", time_string);
		end;
	end;

     end LIST_LV;

LIST_RESERVATIONS: procedure;

	/*   This procedure is called to list information about reservations.
   The reservations that will be listed depend on the control arguments
   specified by the caller. */

	do i = 1 to rli.head.num_device_resv;				/* First look at the devices. */
	     device_resv_ptr = addr (rli.device_resvs (i));
	     if device_resv.reservation_id ^= 0 then			/* This one looks like a good one to list. */
		call LIST_RESERVATION (device_resv.reservation_id);
	end;


	do i = 1 to rli.head.num_vol_resv;				/* Then make sure we haven't missed any volumes. */
	     vol_resv_ptr = addr (rli.vol_resvs (i));
	     if vol_resv.reservation_id ^= 0 then			/* List this one. */
		call LIST_RESERVATION (vol_resv.reservation_id);
	end;


	return;


     end LIST_RESERVATIONS;

LIST_DASSIGNMENT: procedure;

	/* This procedure is called to list the assignment information for
   one device.  If we are in long mode we will list all of the
   device characteristics. */

	num_listed = num_listed + 1;

	if dassign.device_name ^= " "					/* Do we know device name? */
	then call ioa_ ("^5xDevice ^a", dassign.device_name);
	else call ioa_ ("^5xDevice not yet assigned");

	if dassign.state = 0					/* State = 0 => free due to force unassign. */
	then do;
		call ioa_ ("^-State^-=  force unassigned");
		return;
	     end;

	if ^long_flag						/* Does caller want all information? */
	then return;						/* No. */

	if dassign.state = 5					/* State = 5 => assignment completed. */
	then call ioa_ ("^-State^-=  assigned");
	else call ioa_ ("^-State^-=  assigning");
	call date_time_ (dassign.state_time, time_string);
	call ioa_ ("^-Time^-=  ^a", time_string);
	if substr (dassign.disposition, 1, 1)				/* ON => retain,  OFF => unassign. */
	then call ioa_ ("^-Disp^-=  retain");
	else call ioa_ ("^-Disp^-=  unassign");

	if dassign.flags.attached
	then call ioa_ ("^-Device Mounted");

	call ioa_ ("^-Level^-=  ^d", dassign.level);

	if dassign.state ^= 5					/* Is device assignment completed? */
	then return;						/* No, don't print device characteristics. */

	call ioa_ ("^-Model^-=  ^d", dassign.model);

	goto DTYPE (dassign.dtypex);					/* Process device type specific data. */

DTYPE (1):							/* TAPE */
	call ioa_ ("^-Tracks^-=  ^d", dassign.qualifiers (1));
	density_ptr = addr (dassign.qualifiers (2));
	density_comment = "";
	do k = 1 to hbound (density_names, 1);				/* Check for each possible density. */
	     if substr (based_density, k, 1)
	     then density_comment = density_comment || density_names (k);
	end;
	call ioa_ ("^-Densities^-=  ^a", density_comment);
	speed_ptr = addr (dassign.qualifiers (3));
	speed_comment = "";
	do k = 1 to hbound (speed_names, 1);				/* Check for each possible speed. */
	     if substr (based_speed, k, 1)
	     then speed_comment = speed_comment || speed_names (k);
	end;
	call ioa_ ("^-Speed^-=  ^a", speed_comment);
	return;

DTYPE (3):							/* CONSOLE */
	do k = 1 to hbound (console_models, 1);
	     if dassign.model = console_models (k) then do;
		     call ioa_ ("^-Type^-=  ^a", console_model_names (k));
		     return;
		end;
	end;

	call crump (0, "Illegal console model number.");

	return;

DTYPE (4):							/* PRINTER */
	call ioa_ ("^-Train^-=  ^d", dassign.qualifiers (1));
	if dassign.qualifiers (2) = -1				/* -1 => line length not given on PRPH card. */
	then call ioa_ ("^-Line Len^-=  not specified");
	else call ioa_ ("^-Line Len^-=  ^d", dassign.qualifiers (2));
	return;

DTYPE (2):							/* DISK */
DTYPE (5):							/* PUNCH */
DTYPE (6):							/* READER */
DTYPE (7):							/* SPECIAL */

     end LIST_DASSIGNMENT;

LIST_SINGLE_MOUNT: procedure;

	/* This procedure is called to list the information about one mount.
   If we are in long mode we will list all available information. */

	num_listed = num_listed + 1;

	if attach.device_name ^= " "
	then call ioa_ ("^5xDevice ^a", attach.device_name);
	else call ioa_ ("^5xDevice not yet assigned");

	if attach.volume_name ^= " "
	then call ioa_ ("^-Volume^-=  ^a", attach.volume_name);

	if attach.state = 0						/* State = 0 => free due to force unassignment. */
	then do;
		call ioa_ ("^-State^-=  force unassigned");
		return;
	     end;

	if ^long_flag						/* Does user want all available info? */
	then return;						/* No. */

	call ioa_ ("^-State^-=  ^a", operation_states (attach.state));
	call date_time_ (attach.state_time, time_string);
	call ioa_ ("^-Time^-=  ^a", time_string);

	if attach.flags.priv
	then call ioa_ ("^-Attached with privilege");
	if attach.flags.writing
	then call ioa_ ("^-Attached for writing");

	call ioa_ ("^-Level^-=  ^d", attach.level);
	k = attach.workspace_max / 1024;
	call ioa_ ("^-WS Max^-=  ^d K", k);
	seconds = attach.timeout_max / 1000000;
	call ioa_ ("^-TO Max^-=  ^d seconds", seconds);

     end LIST_SINGLE_MOUNT;

LIST_RESERVATION: procedure (arg_rid);


	dcl  arg_rid		     fixed bin (71);
	dcl  request_id_		     entry (fixed bin (71)) returns (char (19));
	dcl  header_printed		     bit (1);			/* Bit to tell whether we have printed resource class. */
	dcl  k			     fixed bin;
	dcl  rid			     fixed bin (71);		/* Reservation to list. */
	dcl  rid_string		     char (32);			/* String representation of reservation id. */


	rid = arg_rid;						/* copy reservation id */


	rid_string = request_id_ (rid);
	if long_flag then						/* Print full reservation id. */
	     call ioa_ ("^/^2xReservation ^a (claimed)", rid_string);
	else call ioa_ ("^/^2xReservation ^a (claimed)", substr (rid_string, 7, 6));


	header_printed = "0"b;
	do k = 1 to rli.head.num_device_resv;				/* Look at all device entries. */
	     device_resv_ptr = addr (rli.device_resvs (k));
	     if device_resv.reservation_id = rid then do;			/* Got one. */
		     if ^header_printed then do;			/* Print header. */
			     call ioa_ ("^5xDevices");
			     header_printed = "1"b;
			end;
		     call ioa_ ("^-^a", device_resv.device_name);
		     device_resv.reservation_id = 0;
		end;
	end;


	header_printed = "0"b;
	do k = 1 to rli.head.num_vol_resv;				/* Look at all vol entries. */
	     vol_resv_ptr = addr (rli.vol_resvs (k));
	     if vol_resv.reservation_id = rid then do;			/* Got one. */
		     if ^header_printed then do;			/* Print header. */
			     call ioa_ ("^5xVolumes");
			     header_printed = "1"b;
			end;
		     call ioa_ ("^-^a", vol_resv.volume_name);
		     vol_resv.reservation_id = 0;
		end;
	end;


	return;


     end LIST_RESERVATION;

LIST_ACQUISITIONS: proc;

	dcl  sys_info$max_seg_size	     ext fixed bin (35) static;

	dcl  define_area_		     ext entry (pointer, fixed bin (35)),
	     release_area_		     ext entry (pointer),
	     get_group_id_		     ext entry returns (char (32)),
	     (rcp_$list_resources, rcp_admin_$list_resources, rcp_admin_$list_awaiting_clear)
				     entry (char (*), char (*), char (*), pointer, fixed bin (35), pointer, fixed bin (35));

	dcl  group_id		     char (32),
	     uname		     char (32),
	     pname		     char (32),
	     n_resources		     fixed bin (35),
	     priv_sw		     bit (1) aligned;

	dcl  1 auto_area_info	     like area_info aligned automatic;

%include area_info;
%include resource_list;

	if resource_type = "" then
	     if awaiting_clear
	     then call crump (error_table_$wrong_no_of_args,
		     "-type must be specified with -awaiting_clear.");
	     else call crump (error_table_$wrong_no_of_args,
		     "-type must be specified with -acquisitions.");

	unspec (auto_area_info) = ""b;
	auto_area_info.version = area_info_version_1;
	auto_area_info.extend,
	     auto_area_info.no_freeing = "1"b;
	auto_area_info.owner = "list_resources";
	auto_area_info.size = sys_info$max_seg_size;
	auto_area_info.areap = temp_seg_ptr;

	call define_area_ (addr (auto_area_info), ecode);
	if ecode ^= 0 then
	     call crump (ecode, "defining temporary area.");

	on cleanup call release_area_ (temp_seg_ptr);			/* no real window exists here -- */
								/* this is only necessary after call to ring 1
						   may extend area to multi segments */

	group_id = get_group_id_ ();
	group_id = substr (group_id, 1, length (rtrim (group_id, " ")) - 2);	/* cut off tag */

	if user_id = "" then user_id = group_id;
	if user_id = group_id then priv_sw = ""b;
	else do;
		uname = before (user_id, ".");
		pname = after (user_id, ".");
		if (uname = "*") & (pname ^= "*") then priv_sw = ""b;
		else priv_sw = "1"b;
	     end;

	if awaiting_clear then
	     call rcp_admin_$list_awaiting_clear (resource_type, registry_dir,
		user_id, temp_seg_ptr, n_resources, resource_list_ptr, ecode);
	else if priv_sw then
	     call rcp_admin_$list_resources (resource_type, registry_dir,
		user_id, temp_seg_ptr, n_resources, resource_list_ptr, ecode);
	else call rcp_$list_resources (resource_type, registry_dir,
		user_id, temp_seg_ptr, n_resources, resource_list_ptr, ecode);

	if ecode ^= 0 then
	     call crump (ecode, "Resource type " || rtrim (resource_type)
		|| " for " || user_id);

	if called_as_af then return_arg = "";
	else do;
		call date_time_ (clock (), time_string);

		call ioa_ ("^[No resources^2s^;^[1 resource^s^;^d resources^]^] of type ^a ^[awaiting manual clear.^;acquired by ^a^[.^; at ^a:^/^]^]",
		     (n_resources = 0), (n_resources = 1), n_resources, resource_type,
		     awaiting_clear, user_id, (n_resources = 0), time_string);
	     end;

	do resource_list_ptr = resource_list_ptr repeat (resource_list.forward_ptr)
	     while (resource_list_ptr ^= null);

	     do i = 1 to resource_list.n_resources;
		if called_as_af then do;
			return_arg = return_arg || rtrim (resource_list.resource_name (i));
			return_arg = return_arg || " ";
		     end;

		else call ioa_ ("^a", resource_list.resource_name (i));
	     end;
	end;

	if called_as_af then
	     return_arg = rtrim (return_arg);

	call release_area_ (temp_seg_ptr);

	return;

     end LIST_ACQUISITIONS;

GET_TEMP_SEG: procedure;

	/* This procedure is called to get a temporary work segment for
   the RLI structure. */

	call get_temp_segment_ ("list_resources", temp_seg_ptr, ecode);
	if ecode ^= 0 then
	     call crump (ecode, "Error getting temporary segment");

	call hcs_$get_max_length_seg (temp_seg_ptr, seg_size, ecode);
	if ecode ^= 0 then
	     call crump (ecode, "Error getting max seg length of temp segment");

	rli_ptr = temp_seg_ptr;

     end GET_TEMP_SEG;

crump: proc (ecode, reason);

	dcl  ecode		     fixed bin (35) parameter,
	     reason		     char (*) parameter;

	dcl  com_err_entry		     entry variable options (variable);

	if called_as_af then com_err_entry = active_fnc_err_;
	else com_err_entry = com_err_;

	call com_err_entry (ecode, "list_resources", "^a", reason);

	if called_as_af then return_arg = "";
	goto RETURN;
     end crump;

test: entry (new_sysdir);

	dcl  new_sysdir		     char (*) parameter;

	if new_sysdir = "" then registry_dir = ">system_control_1>rcp";
	else registry_dir = new_sysdir;
	return;

     end list_resources;




		    parse_resource_desc_.pl1        07/16/87  1349.5r   07/15/87  1548.7      317574



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(86-07-28,Hartogs), approve(86-07-28,MCR7463),
     audit(86-08-06,Lippard), install(86-08-14,MR12.0-1123):
     Make changes to disallow specifying less than 1 resource for reservation.
  2) change(87-06-08,Rauschelbach), approve(87-07-07,MCR7728),
     audit(87-07-08,Farley), install(87-07-15,MR12.1-1040):
     Changed to set the variable err_msg only when this segment is called
     throught the check entry point.
                                                   END HISTORY COMMENTS */

/* format: off */

parse_resource_desc_:
     proc (desc_str, area_ptr, resource_desc_ptr, resource_res_ptr, code);

/*
   This subroutine takes a reservation description string as input and
   returns pointers to two structures containing the necessary information to
   make a reservation of the described resources.  It calls
   cv_rcp_attributes_$from_string_rel to convert the attributes character
   string to a bit string if necessary.
*/

/*
   Written by R.J.C. Kissel 3/78.
   Modified by R.J.C. Kissel 1/79 to handle the new resource description in a compatible fashion.
   Modified by R.J.C. Kissel 3/79 to communicate in a kludgey way with build_resource_desc_.
*/

/* Arguments */

dcl  desc_str char (*);				/* The reservation description string. */
dcl  area_ptr ptr;					/* Area in which to allocate structures. */
						/* See the resource_control_desc.incl.pl1 for ptr declarations. */

dcl  code fixed bin (35);				/* Standard system status code. */

/* Local Variables */

dcl  check bit (1);					/* Syntax checking flag. */
dcl  arg_string char (256) varying;
						/* To hold individual arguments. */
dcl  volume bit (1);				/* Resource type is device or volume. */
dcl  count fixed bin;				/* Count of allocations. */
dcl  cur_pos fixed bin;				/* Current position in desc_str. */
dcl  i fixed bin;					/* Index for accessing structures. */
dcl  junk_bit bit (1);
dcl  rsc_type char (32);				/* primary resource type */

dcl  new ptr;					/* Pointer to a new parse_info structure. */
dcl  head ptr;					/* Pointer to the head of the parse_info list. */
dcl  tail ptr;					/* Pointer to the tail of the parse_info list. */

dcl 1 parse_info based,				/* Structure to save info from each resource description. */
    2 next ptr,					/* Next structure in the list. */
    2 rsc_type char (32),				/* The resource type. */
    2 rsc_name char (32),				/* The resource name. */
    2 attr bit (72) dim (4),				/* The resource attributes. */
    2 number fixed bin;				/* How many of this resource to get. */

/* Local Constants */

/* Local Overlays */

dcl  based_area area (261129) based;
						/* Area overlay. */

/* Include Files */

%include resource_control_desc;

%include rcp_resource_types;

/* External Entries */

dcl  cv_rcp_attributes_$from_string_rel
     entry (char (*), bit (72) dim (4), char (*) varying, fixed bin (35));
dcl  get_system_free_area_
     entry returns (ptr);
dcl  resource_info_$get_primary_type
     entry (char (*), char (*), fixed bin (35));
dcl  resource_info_$get_type
     entry (char (*), bit (1), fixed bin (35));
dcl  get_group_id_ entry returns (char (32));
dcl  build_resource_desc_$reserve
     entry ((*) char (*) varying, ptr, ptr, ptr, ptr, ptr, char (*) varying, fixed bin (35));

/* External Constants */

dcl  error_table_$badcall
     fixed bin (35) external;
dcl  error_table_$noarg fixed bin (35) external;
dcl  error_table_$name_not_found
     fixed bin (35) external;
dcl  error_table_$bad_conversion
     fixed bin (35) external;
dcl  error_table_$bad_index
     fixed bin (35) external;
dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$inconsistent
     fixed bin (35) external;
dcl  error_table_$unbalanced_quotes
     fixed bin (35) external;
dcl  error_table_$resource_type_unknown
     fixed bin (35) external;
dcl  error_table_$resource_spec_ambiguous
     fixed bin (35) external;
dcl  error_table_$area_too_small
     fixed bin (35) external;

/* Builtin Functions and Conditions */

dcl (lbound, hbound, unspec, length, null, convert, substr, ltrim, rtrim)
     builtin;
dcl (cleanup, conversion, area)
     condition;

	check = "0"b;

	if area_ptr = null
	then area_ptr = get_system_free_area_ ();	/* Default area for this entry. */

	goto START;				/* This is the only reference to this label. */

check:
	entry (desc_str, area_ptr, resource_desc_ptr, resource_res_ptr, err_msg, code);

/* *
   This entry takes the same inputs and returns the same outputs as
   parse_resource_desc_.  However, more complete diagnostics are available
   in case an error is detected.
*/

/* Arguments */

dcl  err_msg char (*) varying;			/* A description of an error if one occurs. */

	err_msg = "";
	check = "1"b;

START:						/* There is only one reference to this label. */
dcl 1 token based aligned,
    2 next ptr,
    2 index fixed bin (24),
    2 length fixed bin (24);

dcl  tp ptr;					/* Token pointer. */
dcl  outidx fixed bin (24);
dcl  inidx fixed bin (24);
dcl  token_head_ptr ptr;				/* Start of token list. */
dcl  num_of_tokens fixed bin;
dcl  max_token_length fixed bin (24);
dcl  token_array dim (num_of_tokens) char (max_token_length) varying based;
dcl  tap ptr;					/* Token array pointer. */
dcl  aidx fixed bin;				/* Token array index. */
dcl  token_string char (string_length) based;
dcl  tsp ptr;					/* Token string pointer. */
dcl  string_length fixed bin (24);
dcl  token_index fixed bin (24);
dcl  token_length fixed bin (24);
dcl  token_exists bit (1);
dcl  error_msg char (256) varying;
dcl  new_code fixed bin (35);
dcl  ridx fixed bin;				/* Resource description index. */

	num_of_tokens = 0;
	max_token_length = 0;
	token_head_ptr = null ();
	tap = null ();
	tsp = null ();
	tp = null ();

	on cleanup
	     call Cleanup_Handler;

	string_length = length (desc_str);
	on area
	     goto ERROR_area;
	allocate token_string set (tsp);
	revert area;

	inidx = 1;
	outidx = 1;
	tsp -> token_string = "";

	call Get_Next_Token (desc_str, tsp -> token_string, inidx, outidx, token_index, token_length, token_exists);

	on area
	     goto ERROR_area;

/*
   Push tokens onto a LIFO stack, keeping track of how many there are
   and the length of the longest one.
*/

	do while (token_exists);

	     allocate token set (tp);

	     tp -> token.index = token_index;
	     tp -> token.length = token_length;
	     tp -> token.next = token_head_ptr;

	     token_head_ptr = tp;
	     num_of_tokens = num_of_tokens + 1;

	     if token_length > max_token_length
	     then max_token_length = token_length;

	     call Get_Next_Token (desc_str, tsp -> token_string, inidx, outidx, token_index, token_length, token_exists);
	end;

	if num_of_tokens > 0
	then allocate token_array set (tap);
	else goto ERROR_notype;

	revert area;

/*
   Now fill in the token_array from the end so that the tokens
   will be in their original order.
*/

	do aidx = hbound (tap -> token_array, 1) to lbound (tap -> token_array, 1) by -1;

	     tp = token_head_ptr;
	     if tp = null ()
	     then goto ERROR_internal;

	     tap -> token_array (aidx) = substr (tsp -> token_string, tp -> token.index, tp -> token.length);

	     token_head_ptr = tp -> token.next;
	     free tp -> token;			/* Clean up as we go. */
	end;

	free tsp -> token_string;			/* This is no longer needed. */

/*
   Now call build_resource_desc_$reserve to do the real parsing work
   and error checking.
   Note that for now, build_resource_desc_ can return a zero error
   code and a non-null error message of "User speicfied attributes.".
   This will be used as explained in a comment below.
*/

	call build_resource_desc_$reserve (tap -> token_array, area_ptr, null (), resource_desc_ptr, resource_res_ptr,
	     null (), error_msg, new_code);
	if new_code ^= 0
	then goto ERROR_rdesc;

/*
   Now check the resource description structures to make sure they
   adhere to the very limited rules currently allowed.
*/

	if resource_desc_ptr ^= null ()
	then do;
	     Resource_count = resource_descriptions.n_items;

	     do ridx = 1 to Resource_count by 1;

/*
   Check for possible old description which would be parsed correctly.
*/

		if resource_descriptions.item (ridx).name = VOLUME_TYPE (TAPE_VOL_VTYPEX)
		| resource_descriptions.item (ridx).name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX)
		| resource_descriptions.item (ridx).name = VOLUME_TYPE (DISK_VOL_VTYPEX)
		| resource_descriptions.item (ridx).name = DEVICE_TYPE (DISK_DRIVE_DTYPEX)
		then do;
		     new_code = 0;
		     error_msg = "";
		     call Cleanup_Handler ();
		     revert cleanup;
		     goto OLD_DESCRIPTION_PARSER;
		end;

		call resource_info_$get_primary_type ((resource_descriptions.item (ridx).type), rsc_type, code);
		if code ^= 0 then goto ERROR_type;
		if rsc_type ^= VOLUME_TYPE (TAPE_VOL_VTYPEX)
		& rsc_type ^= DEVICE_TYPE (TAPE_DRIVE_DTYPEX)
		& rsc_type ^= VOLUME_TYPE (DISK_VOL_VTYPEX)
		& rsc_type ^= DEVICE_TYPE (DISK_DRIVE_DTYPEX)
		then goto ERROR_type;

		if (unspec (resource_descriptions.item (ridx).given) & "337777777777"b3) ^= "0"b
		then goto ERROR_carg;

/*
   The following is a kludge agreed upon by parse_resource_desc_ and
   build_resource_desc_.  It allows build_resource_desc_ to pass back information
   about what the user really specified so that parse_resource_desc_ can use it
   here to restrict the acceptable syntax of  a resource description.  This
   must be done because when build_resource_desc_ sets defaults
   the attributes given bit will always be set so that rcp_reserve_ can use
   the defaults even if the user didn't specify any attributes.  This destroys
   any information that build_resource_desc_ could return about what the
   user really said on his command line which is the information that parse_resource_desc_
   currently needs.
*/

		if resource_descriptions.item (ridx).given.name & resource_descriptions.item (ridx).status_code = 1
		then goto ERROR_nmattr;

		if (resource_descriptions.item (ridx).type = VOLUME_TYPE (TAPE_VOL_VTYPEX)
		| resource_descriptions.item (ridx).type = VOLUME_TYPE (DISK_VOL_VTYPEX))
		& ^resource_descriptions.item (ridx).given.name
		then goto ERROR_volnm;
	     end;
	end;

/*
   Done with the extra checks for MR7.0.
*/

	free tap -> token_array;			/* Finish freeing everything. */

	if check
	then err_msg = "";
	code = 0;
	revert cleanup;

	return;

ERROR_type:
	code = error_table_$resource_type_unknown;
	if check
	then err_msg = resource_descriptions.item (ridx).type;
	call Cleanup_Handler ();
	revert cleanup;
	return;

ERROR_carg:
	code = error_table_$badopt;
	if check
	then err_msg = "A control arg other than -attributes or -number was given.";
	call Cleanup_Handler ();
	revert cleanup;
	return;

ERROR_volnm:
	code = error_table_$resource_spec_ambiguous;
	if check
	then err_msg = "Names must be given for volume resource types.";
	call Cleanup_Handler ();
	revert cleanup;
	return;

ERROR_nmattr:
	code = error_table_$inconsistent;
	if check
	then err_msg = "If a name is given then attributes may not be given.";
	call Cleanup_Handler ();
	revert cleanup;
	return;

ERROR_noroom:
	code = error_table_$bad_index;
	if check
	then err_msg = "Internal error in parse_resource_desc_.";
	call Cleanup_Handler ();
	revert cleanup;
	return;

ERROR_noquote:
	code = error_table_$unbalanced_quotes;
	if check
	then err_msg = "Rest of string is: " || substr (desc_str, inidx);
	call Cleanup_Handler ();
	revert cleanup;
	return;

ERROR_internal:
	code = error_table_$bad_index;
	if check
	then err_msg = "Internal indexing error in parse_resource_desc_.";
	call Cleanup_Handler ();
	revert cleanup;
	return;

ERROR_notype:
	code = error_table_$resource_spec_ambiguous;
	if check
	then err_msg = "At least a resource type must be specified.";
	call Cleanup_Handler ();
	revert cleanup;
	return;

ERROR_area:
	code = error_table_$area_too_small;
	if check
	then err_msg = "Not enough area storage to allocate internal structures.";
	call Cleanup_Handler ();
	revert cleanup;
	return;

ERROR_rdesc:					/*
						   For now we have the new error code and the error message, so we will
						   let the old parser have a chance.  If it works, then we will be happy
						   and report no errors.  If it fails then we will report the code and
						   error found here.
						   */
	call Cleanup_Handler ();
	revert cleanup;
	goto OLD_DESCRIPTION_PARSER;

Get_Next_Token:
	proc (P_instr, P_outstr, P_inidx, P_outidx, P_tidx, P_tlen, P_texists);

dcl (
     P_instr char (*),				/* Input  -- string of tokens. */
     P_outstr char (*),				/* Input/Output -- string into which tokens are copied. */
     P_inidx fixed bin (24),				/* Input/Output -- index into P_instr. */
     P_outidx fixed bin (24),				/* Input/Output -- index into P_outstr. */
     P_tidx fixed bin (24),				/* Output -- index in P_outstr of the current token. */
     P_tlen fixed bin (24),				/* Output -- length of the current token. */
     P_texists bit (1)				/* Output -- true if the current token exists. */
     ) parameter;

/*
   D_E_S_C_R_I_P_T_I_O_N_

   This subroutine takes a character string and parses it into
   tokens.  A token is delimited by white space (space, horizontal tab,
   vertical tab, form feed, carrige return, or new line).
   Quoted tokens are handled correctly and are returned with one
   level of quotes stripped.  The token is returned by giving its index
   and length in P_outstr.
   Notice that P_outstr need be no longer than P_instr (because
   quotes and white space are only removed, never added).
   Also, the caller should never modify the Input/Output parameters:
   P_inidx, P_outidx, and P_outstr.  However, on the first call both
   P_inidx and P_outidx should be initialized to 1, and P_outstr should
   be initailized to the null string.  P_instr is never modified by
   this subroutine.


   J_O_U_R_N_A_L_I_Z_A_T_I_O_N_

   1) Written 11/78 by R.J.C. Kissel.
*/

/* Local Variables */

dcl  start_of_token fixed bin (24);
dcl  length_of_token fixed bin (24);
dcl  subtoken_len fixed bin (24);
dcl  subtoken_idx fixed bin (24);
dcl  outidx fixed bin (24);
dcl  more_string bit (1);


/* Local Constants */

dcl  C_true bit (1) init ("1"b);
dcl  C_false bit (1) init ("0"b);
dcl  C_quote char (1) init ("""");
dcl  C_white_space char (6) init (" 	
");
						/* SP, HT, VT, FF, CR, NL */

/* Builtin Fucntions and Conditions */

dcl (length, substr, search, verify)
     builtin;

	     if P_inidx = length (P_instr) + 1
	     then do;				/* The input string is already processed. */
		P_tidx = 0;
		P_tlen = 0;
		P_texists = C_false;
		return;
	     end;					/* The input string is already processed. */

	     length_of_token = 0;
	     start_of_token = verify (substr (P_instr, P_inidx), C_white_space) + P_inidx - 1;

	     if start_of_token = P_inidx - 1
	     then do;				/* There is no token, only white space. */
		P_inidx = length (P_instr) + 1;	/* Last character index + one. */
		P_tidx = 0;
		P_tlen = 0;
		P_texists = C_false;
	     end;					/* There is no token, only white space. */

	     else do;				/* There is a token to process. */
		if substr (P_instr, start_of_token, 1) ^= C_quote
		then do;				/* Process a regular token. */
		     length_of_token = search (substr (P_instr, start_of_token), C_white_space) - 1;
		     if length_of_token = -1
		     then length_of_token = length (substr (P_instr, start_of_token));

		     if search (substr (P_instr, start_of_token, length_of_token), C_quote) ^= 0
		     then goto ERROR_noquote;		/* Don't allow embedded quotes. */

		     if P_outidx + length_of_token - 1 > length (P_outstr)
		     then goto ERROR_noroom;
		     substr (P_outstr, P_outidx, length_of_token) = substr (P_instr, start_of_token, length_of_token);
						/* copy the token. */

		     P_tidx = P_outidx;
		     P_tlen = length_of_token;
		     P_texists = C_true;

		     P_inidx = start_of_token + length_of_token;
		     P_outidx = P_outidx + length_of_token;
		end;				/* Process a regular token. */

		else do;				/* Process a quoted string token. */
		     outidx = P_outidx;
		     subtoken_idx = start_of_token;
		     more_string = C_true;

		     do while (more_string);
			subtoken_idx = subtoken_idx + 1;
						/* Skip the initial quote. */
			subtoken_len = search (substr (P_instr, subtoken_idx), C_quote) - 1;
						/* Look for the next quote. */
			if subtoken_len = -1
			then goto ERROR_noquote;

/*
   Now copy the subtoken we just found without the final quote and
   checking for the null string.
*/

			if subtoken_len > 0
			then do;			/* There is something to copy. */
			     if outidx + subtoken_len - 1 > length (P_outstr)
			     then goto ERROR_noroom;
			     substr (P_outstr, outidx, subtoken_len) =
				substr (P_instr, subtoken_idx, subtoken_len);
						/* copy the token. */
			     outidx = outidx + subtoken_len;
						/* Move the index in P_outstr to the next available position. */
			end;			/* There is something to copy. */

			length_of_token = length_of_token + subtoken_len;
						/* Keep track of the total length of the token. */

			subtoken_idx = subtoken_idx + subtoken_len + 1;
						/* Skip the final quote in the subtoken. */

			if substr (P_instr, subtoken_idx, 1) = C_quote
			then do;			/* Take care of a doubled quote. */
			     if outidx + 1 - 1 > length (P_outstr)
			     then goto ERROR_noroom;

			     substr (P_outstr, outidx, 1) = C_quote;
						/* Copy the quote. */
			     outidx = outidx + 1;
						/* Move the index in P_outstr to the next available position. */
			     length_of_token = length_of_token + 1;
						/* Keep track of the total length of the token. */
			end;			/* Take care of a doubled quote. */

			else if verify (substr (P_instr, subtoken_idx, 1), C_white_space) ^= 0
			then goto ERROR_noquote;

			else more_string = C_false;
						/* Done with the quoted token. */
		     end;

		     P_tidx = P_outidx;
		     P_tlen = length_of_token;
		     P_texists = C_true;

		     P_inidx = subtoken_idx;
		     P_outidx = P_outidx + length_of_token;
		end;				/* Process a quoted string token. */
	     end;					/* There is a token to process. */

	end Get_Next_Token;

Cleanup_Handler:
	proc ();

	     if tap ^= null ()
	     then free tap -> token_array;

	     if tsp ^= null ()
	     then free tsp -> token_string;

	     if tp ^= null () & tp ^= token_head_ptr
	     then free tp -> token;			/* A small window. */

	     do while (token_head_ptr ^= null ());
		tp = token_head_ptr;
		token_head_ptr = tp -> token.next;
		free tp -> token;
	     end;

	     if area_ptr ^= null ()
	     then do;
		if resource_desc_ptr ^= null ()
		then do;
		     free resource_descriptions in (area_ptr -> based_area);
		     resource_desc_ptr = null ();
		end;

		if resource_res_ptr ^= null ()
		then do;
		     free reservation_description in (area_ptr -> based_area);
		     resource_res_ptr = null ();
		end;
	     end;
	end Cleanup_Handler;

OLD_DESCRIPTION_PARSER:				/* Initialize pointers and local variables. */
	resource_desc_ptr = null;
	resource_res_ptr = null;
	code = 0;

	arg_string = "";
	volume = "0"b;
	count = 0;
	cur_pos = 0;

	new = null;
	head = null;
	tail = null;


	on cleanup
	     call cleanup_handler;

	arg_string = get_next_arg (desc_str, cur_pos);

	if arg_string = ""
	then goto BAD_DESC;

	do while (arg_string ^= "");			/* Process one resource description at a time. */

/* Check the validity of the resource type argument. */

	     call resource_info_$get_type ((arg_string), volume, code);

	     if code ^= 0
	     then goto BAD_TYPE;

/* Process all the arguments for one resource description. */

	     allocate parse_info set (new);
	     new -> parse_info.next = null;
	     new -> parse_info.rsc_type = arg_string;
	     new -> parse_info.rsc_name = "";
	     new -> parse_info.attr = "0"b;
	     new -> parse_info.number = 1;		/* There is at least one. */

	     if head = null
	     then head = new;

	     if tail ^= null
	     then tail -> parse_info.next = new;

	     tail = new;

	     if ^volume
	     then do;				/* This is a device type resource. */
		arg_string = get_next_arg (desc_str, cur_pos);

		if arg_string = ""
		then do;				/* All defaults apply and we are done. */
		     call cv_rcp_attributes_$from_string_rel (new -> parse_info.rsc_type,
			new -> parse_info.attr, "", code);

		     if code ^= 0
		     then goto BAD_DEFAULT;
		end;				/* All defaults apply and we are done. */

		else if arg_string = "-name" | arg_string = "-nm"
		then do;				/* A strange name argument. */
		     arg_string = get_next_arg (desc_str, cur_pos);

		     if arg_string = ""
		     then goto BAD_NAME_ARG;

		     new -> parse_info.rsc_name = arg_string;
		     arg_string = get_next_arg (desc_str, cur_pos);
		end;				/* A strange name argument. */

		else if arg_string = "-attributes" | arg_string = "-attr"
		then do;				/* Attributes argument. */
		     arg_string = get_next_arg (desc_str, cur_pos);

		     if arg_string = ""
		     then goto BAD_ATTR_ARG;

		     call cv_rcp_attributes_$from_string_rel (new -> parse_info.rsc_type,
			new -> parse_info.attr, arg_string, code);

		     if code ^= 0
		     then goto BAD_ATTR;

		     arg_string = get_next_arg (desc_str, cur_pos);

		     if arg_string = "-number" | arg_string = "-nb"
		     then do;			/* We can have a number in this case. */
			arg_string = get_next_arg (desc_str, cur_pos);

			if arg_string = ""
			then goto BAD_NUM_ARG;

			on conversion
			     goto BAD_NUMBER;

			new -> parse_info.number = convert (new -> parse_info.number, arg_string);
			revert conversion;

			if new -> parse_info.number <= 0 then
			   goto BAD_NUMBER;

			arg_string = get_next_arg (desc_str, cur_pos);

		     end;				/* We can have a number in this case. */
		end;				/* Attributes argument. */

		else if arg_string = "-number" | arg_string = "-nb"
		then do;				/* Number argument. */
		     arg_string = get_next_arg (desc_str, cur_pos);

		     if arg_string = ""
		     then goto BAD_NUM_ARG;

		     on conversion
			goto BAD_NUMBER;

		     new -> parse_info.number = convert (new -> parse_info.number, arg_string);
		     revert conversion;

		     if new -> parse_info.number <= 0 then
		        goto BAD_NUMBER;

		     arg_string = get_next_arg (desc_str, cur_pos);

		     if arg_string ^= "-attributes" & arg_string ^= "-attr"
		     then do;			/* Get default attributes. */
			call cv_rcp_attributes_$from_string_rel (new -> parse_info.rsc_type,
			     new -> parse_info.attr, "", code);

			if code ^= 0
			then goto BAD_DEFAULT;

		     end;				/* Get default attributes. */

		     else do;			/* Attributes argument. */
			arg_string = get_next_arg (desc_str, cur_pos);

			if arg_string = ""
			then goto BAD_ATTR_ARG;

			call cv_rcp_attributes_$from_string_rel (new -> parse_info.rsc_type,
			     new -> parse_info.attr, arg_string, code);

			if code ^= 0
			then goto BAD_ATTR;

			arg_string = get_next_arg (desc_str, cur_pos);
		     end;				/* Attributes argument. */
		end;				/* Number argument. */

		else do;				/* A device name may have been given. */

		     call resource_info_$get_type ((arg_string), junk_bit, code);
						/* Just want the code. */

		     if code ^= 0
		     then do;			/* A device name. */
			if code = error_table_$name_not_found
			then do;
			     code = 0;
			     new -> parse_info.rsc_name = arg_string;
			     arg_string = get_next_arg (desc_str, cur_pos);
			end;

			else goto BAD_ERROR;
		     end;				/* A device name. */
		end;				/* A device name may have been given. */
	     end;					/* This is a device type resource. */

	     else do;				/* This is a volume type resource. */
		arg_string = get_next_arg (desc_str, cur_pos);

		if arg_string = ""
		then goto BAD_VOL_NAME;

		if arg_string = "-name" | arg_string = "-nm"
		then do;				/* Strange name argument. */
		     arg_string = get_next_arg (desc_str, cur_pos);

		     if arg_string = ""
		     then goto BAD_NAME_ARG;

		     new -> parse_info.rsc_name = arg_string;
		end;				/* Strange name argument. */

		else if substr (arg_string, 1, 1) = "-"
		then goto BAD_VOL_NAME;

		else new -> parse_info.rsc_name = arg_string;

		arg_string = get_next_arg (desc_str, cur_pos);
	     end;					/* This is a volume type resource. */

	     count = count + tail -> parse_info.number;

	end;					/* Process one resource description at a time. */

/* Now build the structures to return in the appropriate area. */

	if area_ptr = null
	then do;					/* We are done. */
	     code = 0;
	     call cleanup_handler;
	     return;
	end;					/* We are done. */

	Resource_count = count;			/* Need this to allocate the structures. */

	on area
	     goto BAD_AREA;
	allocate resource_descriptions in (area_ptr -> based_area) set (resource_desc_ptr);
	allocate reservation_description in (area_ptr -> based_area) set (resource_res_ptr);
	revert area;

/* Fill in the constant parts of the structures with the given information and defaults. */

	resource_descriptions.version_no = resource_desc_version_1;
	resource_descriptions.n_items = Resource_count;

	reservation_description.version_no = resource_res_version_1;
	reservation_description.reserved_for = get_group_id_ ();
	reservation_description.reserved_by = get_group_id_ ();
	reservation_description.group_starting_time = 0;
	reservation_description.asap_duration = 0;
	reservation_description.auto_expire = "0"b;
	reservation_description.asap = "0"b;
	reservation_description.rel = "1"b;
	reservation_description.sec = "0"b;
	reservation_description.n_items = Resource_count;

/* Fill in the variable parts of the structures with the given information and defaults. */

	new = head;

	do i = 1 to Resource_count by 1;
	     resource_descriptions.item (i).type = new -> parse_info.rsc_type;
	     resource_descriptions.item (i).name = new -> parse_info.rsc_name;
	     resource_descriptions.item (i).uid = "0"b;
	     resource_descriptions.item (i).potential_attributes = "0"b;
	     resource_descriptions.item (i).desired_attributes (*) = new -> parse_info.attr (*);
	     resource_descriptions.item (i).owner = "";
	     resource_descriptions.item (i).acs_path = "";
	     resource_descriptions.item (i).aim_range (*) = "0"b;
	     resource_descriptions.item (i).potential_aim_range (*) = "0"b;
	     resource_descriptions.item (i).location = "";
	     resource_descriptions.item (i).comment = "";
	     resource_descriptions.item (i).charge_type = "";

	     unspec (resource_descriptions.item (i).given) = "0"b;
						/* Set everything off to start. */
	     resource_descriptions.item (i).given.name = (resource_descriptions.item (i).name ^= "");
	     resource_descriptions.item (i).given.uid = (resource_descriptions.item (i).uid ^= "0"b);

	     if (resource_descriptions.item (i).desired_attributes (1)
	     | resource_descriptions.item (i).desired_attributes (2)
	     | resource_descriptions.item (i).desired_attributes (3)
	     | resource_descriptions.item (i).desired_attributes (4)) = "0"b
	     then resource_descriptions.item (i).given.desired_attributes = "0"b;
	     else resource_descriptions.item (i).given.desired_attributes = "1"b;

	     resource_descriptions.item (i).given.owner = (resource_descriptions.item (i).owner ^= "");

	     if (resource_descriptions.item (i).aim_range (1) | resource_descriptions.item (i).aim_range (2)) = "0"b
	     then resource_descriptions.item (i).given.aim_range = "0"b;
	     else resource_descriptions.item (i).given.aim_range = "1"b;

	     resource_descriptions.item (i).rew = "0"b;
	     resource_descriptions.item (i).usage_lock = "0"b;
	     resource_descriptions.item (i).release_lock = "0"b;
	     resource_descriptions.item (i).awaiting_clear = "0"b;
	     resource_descriptions.item (i).user_alloc = "0"b;
	     resource_descriptions.item (i).pad2 = "0"b;
	     resource_descriptions.item (i).state = "0"b;
	     resource_descriptions.item (i).status_code = 0;

	     reservation_description.reservation_group (i).starting_time = 0;
	     reservation_description.reservation_group (i).duration = 0;

	     if new -> parse_info.number = 1
	     then new = new -> parse_info.next;
	     else new -> parse_info.number = new -> parse_info.number - 1;
	end;					/* Fill in variable parts. */

	if check
	then err_msg =
	     "Warning: the old format resource description """ || ltrim (rtrim (desc_str))
	     || """ should be converted to the new format.";

	code = 0;
	return;

/* Error handling section */

BAD_ERROR:
	if new_code = 0
	then do;
	     if check
	     then err_msg = "An error occurred in RCP, contact a systems programmer.";
	end;

	else do;
	     code = new_code;
	     if check 
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

BAD_DESC:
	if new_code = 0
	then do;
	     code = error_table_$noarg;
	     if check
	     then err_msg = "At least one resource type must be given in the resource description.";
	end;

	else do;
	     code = new_code;
	     if check
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

BAD_NUMBER:
	if new_code = 0
	then do;
	     code = error_table_$bad_conversion;
	     if check
	     then err_msg = "Invalid number: " || arg_string;
	end;

	else do;
	     code = new_code;
	     if check 
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

BAD_TYPE:
	if new_code = 0
	then do;
	     code = error_table_$badcall;
	     if check
	        then err_msg = "The specified resource type is not valid: " || arg_string;
	end;

	else do;
	     code = new_code;
	     if check
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

BAD_DEFAULT:
	if new_code = 0
	then do;
	     if check
	        then err_msg = "An error occurred setting default attributes for " || new -> parse_info.rsc_type;
	end;

	else do;
	     code = new_code;
	     if check
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

BAD_NAME_ARG:
	if new_code = 0
	then do;
	     code = error_table_$noarg;
	     if check
	        then err_msg = "Name argument missing for resource type " || new -> parse_info.rsc_type;
	end;

	else do;
	     code = new_code;
	     if check
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

BAD_ATTR_ARG:
	if new_code = 0
	then do;
	     code = error_table_$noarg;
	     if check
	     then err_msg = "Attribute argument missing for resource type " || new -> parse_info.rsc_type;
	end;

	else do;
	     code = new_code;
	     if check
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

BAD_ATTR:
	if new_code = 0
	then do;
	     if check
	     then err_msg = "Error converting attribute string: " || arg_string;
	end;

	else do;
	     code = new_code;
	     if check 
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

BAD_NUM_ARG:
	if new_code = 0
	then do;
	     code = error_table_$noarg;
	     if check
	     then err_msg = "Number argument missing for resource type " || new -> parse_info.rsc_type;
	end;

	else do;
	     code = new_code;
	     if check 
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

BAD_VOL_NAME:
	if new_code = 0
	then do;
	     code = error_table_$noarg;
	     if check
	     then err_msg = "The volume name must be specified for resource type " || new -> parse_info.rsc_type;
	end;

	else do;
	     code = new_code;
	     if check 
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

BAD_AREA:
	if new_code = 0
	then do;
	     code = error_table_$badcall;
	     if check
	     then err_msg = "The specified area is not big enough to hold the necessary structures.";
	end;

	else do;
	     code = new_code;
	     if check 
	        then err_msg = error_msg;
	end;

	call cleanup_handler;
	return;

get_next_arg:
	proc (in_string, position) returns (char (256) varying);

/*
   This subroutine takes a character string as input and picks out the next
   argument delimited by blanks.  It returns the null string if there are no
   more arguments.
*/

/* Arguments */

dcl  in_string char (*);				/* Input string. */
dcl  position fixed bin;				/* An index always left pointing just after the arg */
						/* returned in in_string. */
dcl  arg char (256) varying;
						/* The returned argument. */

/* Local Variables */

dcl  pos1 fixed bin;				/* Start of string. */
dcl  pos2 fixed bin;				/* End of string. */

/* Builtin Functions and Conditions */

dcl (substr, verify, search, length)
     builtin;

	     if position = length (in_string)
	     then do;				/* No more args left. */
		arg = "";
		return (arg);
	     end;					/* No more args left. */

	     if position = 0
	     then position = 1;			/* Ready for use in substr. */

	     pos1 = verify (substr (in_string, position), " ");

	     if pos1 = 0
	     then do;				/* String is all blanks. */
		arg = "";
		position = length (in_string);
		return (arg);
	     end;					/* String is all blanks. */

	     pos1 = pos1 + position - 1;		/* Get index in the whole string. */
	     pos2 = search (substr (in_string, pos1), " ");

	     if pos2 = 0
	     then do;				/* Last arg in string. */
		arg = substr (in_string, pos1);
		position = length (in_string);
		return (arg);
	     end;					/* Last arg in string. */

	     else do;				/* Some middle arg in the string. */
		pos2 = pos2 + pos1 - 1;		/* Get index in the whole string. */
		arg = substr (in_string, pos1, pos2 - pos1);
		position = pos2;
		return (arg);
	     end;					/* Some middle arg in the string. */

	end get_next_arg;

cleanup_handler:
	proc;

	     if head ^= null | tail ^= null | new ^= null
	     then do;				/* Free the parse_info list. */

		if tail ^= new
		then do;
		     if new ^= null
		     then free new -> parse_info;
		     if tail ^= null
		     then tail -> parse_info.next = null;
						/* Make sure the list ends. */
		end;

		if head ^= null
		then do;				/* Free the list from head to tail. */

		     do while (head ^= null);
			new = head -> parse_info.next;
			free head -> parse_info;
			head = new;
		     end;
		end;				/* Free the list from head to tail. */
	     end;					/* Free the parse_info list. */

	     if area_ptr ^= null
	     then do;				/* Free the output structures. */

		if resource_desc_ptr ^= null
		then do;
		     free resource_descriptions in (area_ptr -> based_area);
		     resource_desc_ptr = null;
		end;

		if resource_res_ptr ^= null
		then do;
		     free reservation_description in (area_ptr -> based_area);
		     resource_res_ptr = null;
		end;
	     end;					/* Free the output structures. */

	     call Cleanup_Handler ();

	end cleanup_handler;
     end parse_resource_desc_;




		    register_resource.pl1           08/06/87  1422.1rew 08/06/87  1304.7      126747



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(87-06-19,Rauschelbach), approve(87-06-29,MCR7736),
     audit(87-07-21,Farley), install(87-08-06,MR12.1-1064):
     Error message duplication was removed, and a call to com_err_ with a more
     standard version.
                                                   END HISTORY COMMENTS */


/* format:style4,delnl,insnl,indattr,ifthen,dclind10 */
register_resource:
rgr:
     proc;

/* This command registers a resource or a number of resources.
   Written 10/09/78 by C. D. Tavares */
/* Modified 08/79 by CDT to remove warning when default attributes are
   supplied from RTDT on registration.  The fix is not a complete solution. */
/* Modified 12/10/79 by CDT to get rid of timer sleep code which is now
   handled in ring 1 */
/* Last modified 06/17/81 by CDT to make error messages nicer and to reject
   -owner in set_resource call. */
/* Modified 841106 to query users when registering/acquiring multi-class volumes which are basically useless... - M. M. Pozzo */

/* automatic */

dcl	action		   fixed bin,
	ap		   pointer,
	al		   fixed bin,
	alp		   pointer,
	arg_positions_ptr	   pointer,
	eca_ptr		   pointer,
	nargs		   fixed bin,
	position		   fixed bin,
	code		   fixed bin (35),
	i		   fixed bin,
	myname		   char (32),
	err_msg		   char (256) varying,
	resource_subtype	   char (32),
	yes_sw		   bit (1);

/* external static */

dcl	(
	sys_info$max_seg_size,
	error_table_$noarg,
	error_table_$inconsistent,
	error_table_$lock_wait_time_exceeded,
	error_table_$resource_not_modified,
	error_table_$action_not_performed
	)		   external fixed bin (35) static;

/* entries */

dcl	aim_check_$equal
			   entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	build_resource_desc_$from_arglist
			   ext
			   entry (pointer, pointer, pointer, pointer, bit (1) aligned, pointer, char (*) varying,
			   fixed bin (35));

dcl	define_area_	   ext entry (pointer, fixed bin (35)),
	release_area_	   ext entry (pointer);

dcl	command_query_$yes_no  entry options (variable),
	cu_$arg_count	   ext entry (fixed bin),
	cu_$arg_ptr	   ext entry (fixed bin, pointer, fixed bin, fixed bin (35)),
	cu_$arg_list_ptr	   ext entry (pointer);

dcl	ioa_		   ext entry options (variable);

dcl	resource_info_$defaults
			   ext entry (char (*) aligned, char (*), pointer, fixed bin, fixed bin (35));

dcl	(
	rcp_admin_$register,
	rcp_admin_$deregister,
	rcp_sys_$clear_resource,
	rcp_admin_$acquire,
	rcp_$acquire,
	rcp_admin_$release,
	rcp_$release,
	rcp_admin_$set_status,
	rcp_$set_status
	)		   ext entry (pointer, char (*), fixed bin (35));

/* based */

dcl	arg		   char (al) based (ap),
	temp_area		   area (1000) based (auto_area_info.areap),
	arg_positions	   (eca_ptr -> arg_struc_template.n_extra_args) fixed bin based (arg_positions_ptr);

dcl	1 arg_struc_template   aligned based (eca_ptr),
	  2 n_extra_args	   fixed bin,
	  2 each		   (0 refer (arg_struc_template.n_extra_args)),
	    3 long_name	   char (32),
	    3 short_name	   char (32),
	    3 n_following	   fixed bin;

/* builtins */

dcl	(addr, null, unspec, index)
			   builtin;

/* conditions */

dcl	cleanup		   condition;

/* static */

dcl	sys_dir		   char (168) static initial (">system_control_1>rcp");

/* constants */

dcl	1 register_control_args
			   aligned static options (constant),
	  2 n_extra_args	   fixed bin initial (1),
	  2 each		   (1),
	    3 long_name	   char (32) initial ("-type"),
	    3 short_name	   char (32) initial ("-tp"),
	    3 n_following	   fixed bin initial (1);

dcl	1 no_control_args	   aligned static options (constant),
	  2 n_extra_args	   fixed bin initial (0);

dcl	1 only_priv_control_arg
			   aligned static options (constant),
	  2 n_extra_args	   fixed bin initial (1),
	  2 each		   (1),
	    3 long_name	   char (32) initial ("-priv"),
	    3 short_name	   char (32) initial ("-priv"),
	    3 n_following	   fixed bin initial (0);

dcl	(
	Register		   initial (1),
	Deregister	   initial (2),
	Acquire		   initial (3),
	Release		   initial (4),
	Set		   initial (5),
	Clear		   initial (6)
	)		   fixed bin static options (constant);
%page;
%include resource_control_desc;
%page;
%include area_info;

dcl	1 auto_area_info	   aligned automatic like area_info;
%page;
	action = Register;
	myname = "register_resource";
	goto common;
%skip (4);
deregister_resource:
drr:
     entry;

	action = Deregister;
	myname = "deregister_resource";
	goto common;
%skip (4);
acquire_resource:
aqr:
     entry;

	action = Acquire;
	myname = "acquire_resource";
	goto common;
%skip (4);
release_resource:
rlr:
     entry;

	action = Release;
	myname = "release_resource";
	goto common;
%skip (4);
set_resource:
setr:
     entry;

	action = Set;
	myname = "set_resource";
	goto common;
%skip (4);
clear_resource:
clr:
     entry;

	action = Clear;
	myname = "clear_resource";
	goto common;
%skip (4);
common:
	unspec (auto_area_info) = ""b;
	auto_area_info.version = area_info_version_1;
	auto_area_info.owner = myname;
	auto_area_info.size = sys_info$max_seg_size;
	auto_area_info.areap = null;
	auto_area_info.extend, auto_area_info.no_freeing = "1"b;

	call cu_$arg_count (nargs);
	if nargs < 2 then
noarg:
	     call crump (error_table_$noarg, "Usage: ^a resource_type resource_names {-control_args}");

	call cu_$arg_list_ptr (alp);

	on cleanup call clean_up;

	call define_area_ (addr (auto_area_info), code);
	if code ^= 0 then
	     call crump (code, "Defining area.");

	if action = Register then
	     eca_ptr = addr (register_control_args);
	else if (action = Deregister) | (action = Clear) then
	     eca_ptr = addr (no_control_args);
	else eca_ptr = addr (only_priv_control_arg);

	allocate arg_positions in (temp_area);

	call build_resource_desc_$from_arglist (alp, auto_area_info.areap, eca_ptr, resource_desc_ptr,
	     (action = Register), arg_positions_ptr, err_msg, code);
	if code ^= 0 then
	     call crump (code, (err_msg));

	if resource_descriptions.n_items <= 0 then
	     goto noarg;


	goto process_action (action);
%page;
process_action (1):					/* register */
	if ^resource_descriptions.item (1).given.owner then do;
	     if resource_descriptions.item (1).given.aim_range then
		err_msg = "-access_class";
	     else if resource_descriptions.item (1).given.acs_path then
		err_msg = "-acs_path";
	     else if resource_descriptions.item (1).given.comment then
		err_msg = "-comment";
	     else if resource_descriptions.item (1).given.user_alloc then
		err_msg = "-user_alloc";
	     else if resource_descriptions.item (1).given.release_lock then
		err_msg = "-release_lock";
	     else err_msg = "";

	     if err_msg ^= "" then do;
		err_msg = err_msg || " requires -owner";
		call crump (error_table_$inconsistent, (err_msg));
	     end;


	end;					/*  See if this is an acquire as well and if so, if this is a multi-class volume if the user really wants to do this */

	if ^multi_class_volume_continue () then do;
	     err_msg = "User does not wish to acquire useless multi-class volume";
	     call crump (error_table_$action_not_performed, (err_msg));
	end;


/* We get the defaults for this type of resource and fill them into the
   structure that we got back from build_resource_desc_ if they aren't already
   provided.  Notice that we only do this for ONE resource type-- because the
   current syntax of the registration command only provides for registering
   resources of one resource type at a time;  plus all of the resources share
   common control arguments, meaning that you can't (say) provide attributes
   for one resource but not the others;  so we assume that if the first
   resource in the structure doesn't have something, none of them have it.  */

	Resource_count = 1;				/* get defaults for type */

	if search_list ("-type", position) then do;
	     call cu_$arg_ptr (position + 1, ap, al, code);
	     if code ^= 0 then
		call crump (code, "after -type.");
	     resource_subtype = arg;
	end;
	else resource_subtype = "";

	call resource_info_$defaults (resource_descriptions.item (1).type, resource_subtype, resource_desc_ptr, 0, code)
	     ;
	if code ^= 0 then
	     call crump (code, "Obtaining defaults.");

	call rcp_admin_$register (resource_desc_ptr, sys_dir, code);
	if code ^= 0 then
	     call crump_in_struc (code, "Cannot register resources.");

	goto process_action_end;

process_action (2):					/* deregister */
	call rcp_admin_$deregister (resource_desc_ptr, sys_dir, code);
	if code ^= 0 then
	     call crump_in_struc (code, "Cannot deregister resources.");

	goto process_action_end;

process_action (3):					/* acquire */
						/*  If this is a multi-class volume acquire, make sure user really wants to do this */
	if ^multi_class_volume_continue () then do;
	     err_msg = "User does not wish to acquire useless multi-class volume";
	     call crump (error_table_$action_not_performed, (err_msg));
	end;

	if search_list ("-priv", 0) then
	     call rcp_admin_$acquire (resource_desc_ptr, sys_dir, code);
	else call rcp_$acquire (resource_desc_ptr, sys_dir, code);
	if code ^= 0 then
	     call crump_in_struc (code, "Cannot acquire resources.");

	do i = 1 to resource_descriptions.n_items;
	     if ^resource_descriptions.given.name (i) then
		call ioa_ ("Resource ^a ^a acquired.", resource_descriptions.type (i),
		     resource_descriptions.item.name (i));
	end;

	goto process_action_end;

process_action (4):					/* release */
	if release_continue () then
	     if search_list ("-priv", 0) then
		call rcp_admin_$release (resource_desc_ptr, sys_dir, code);
	     else call rcp_$release (resource_desc_ptr, sys_dir, code);
	if code ^= 0 then
	     call crump_in_struc (code, "Cannot release resources.");

	goto process_action_end;

process_action (5):					/* set */
	if resource_descriptions.item (1).given.owner then
	     call crump (error_table_$resource_not_modified, "Cannot modify resource owner via set_resource.");

	if search_list ("-priv", 0) then
	     call rcp_admin_$set_status (resource_desc_ptr, sys_dir, code);
	else call rcp_$set_status (resource_desc_ptr, sys_dir, code);
	if code ^= 0 then
	     call crump_in_struc (code, "Cannot set resources.");

	goto process_action_end;

process_action (6):					/* clear */
	call rcp_sys_$clear_resource (resource_desc_ptr, sys_dir, code);
	if code ^= 0 then
	     call crump_in_struc (code, "Cannot clear resources.");

	goto process_action_end;

process_action_end:
	call clean_up;

/* ----- */

clean_up:
     proc;

	if auto_area_info.areap ^= null then
	     call release_area_ (auto_area_info.areap);

     end clean_up;

/* ----- */

return_hard:
	return;
%skip (4);
search_list:
     proc (desired_arg, position) returns (bit (1) aligned);

dcl	desired_arg	   char (*) parameter,
	position		   fixed bin parameter;

dcl	i		   fixed bin;

	do i = 1 to eca_ptr -> arg_struc_template.n_extra_args
	     while (eca_ptr -> arg_struc_template.long_name (i) ^= desired_arg);
	end;

	if i ^> eca_ptr -> arg_struc_template.n_extra_args then do;
	     position = arg_positions (i);
	     if position > 0 then
		return ("1"b);
	     else return (""b);
	end;

	position = -1;
	return (""b);

     end search_list;
%skip (4);
crump:
     proc (code, reason);

dcl	code		   fixed bin (35),
	reason		   char (*);

dcl	(
	com_err_,
	com_err_$suppress_name
	)		   ext entry options (variable),
	i		   fixed bin;

	call com_err_ (code, myname, reason, myname);
	call clean_up;
	goto return_hard;

crump_in_struc:
     entry (code, reason);

	do i = 1 to resource_descriptions.n_items while (resource_descriptions.item (i).status_code = 0);
	end;

	if i <= resource_descriptions.n_items then
	   call com_err_ (code, myname, reason);
	else call com_err_ (resource_descriptions.item (i).status_code, myname, "for ^a ^a",
		resource_descriptions.item (i).type, resource_descriptions.item (i).name);

	if code = error_table_$lock_wait_time_exceeded then
	     call com_err_$suppress_name (code, myname, "Resource registry is busy.");

	call clean_up;

	goto return_hard;

     end crump;
%skip (4);
test:
     entry (new_sys_dir);

dcl	new_sys_dir	   char (*) parameter;

	if new_sys_dir = "" then
	     sys_dir = ">system_control_1>rcp";
	else sys_dir = new_sys_dir;
	return;
%skip (4);
multi_class_volume_continue:
     proc () returns (bit (1));

dcl	continue		   bit (1);
	continue = "1"b;				/* Are we acquiring a multi-class resource */

	if (resource_descriptions.item (1).given.owner & resource_descriptions.item (1).given.aim_range) then do;

/* Is it a multi-class volume? */

	     if index (resource_descriptions.item (1).type, "vol") ^= 0 then do;

/* Is the min_access_class < max_access_class? */

		if ^aim_check_$equal (resource_descriptions.item (1).aim_range (1),
		     resource_descriptions.item (1).aim_range (2)) then do;

/* Does the user wish to continue? */
		     call command_query_$yes_no (yes_sw, 0, myname, "",
			"Do you really want to acquire a multi-class volume?");
		     if ^yes_sw then
			continue = "0"b;
		end;
	     end;
	end;
	return (continue);

     end multi_class_volume_continue;
%page;
release_continue:
     proc () returns (bit (1));

dcl	continue		   bit (1);
	continue = "1"b;

	call command_query_$yes_no (yes_sw, 0, myname, "",
	     "Releasing this resource may cause it to be degaussed.  Do you wish to continue?");

	if ^yes_sw then
	     continue = "0"b;

	return (continue);
     end release_continue;

     end register_resource;




		    reserve_resource.pl1            11/04/82  1936.3rew 11/04/82  1619.2       30555



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


reserve_resource:
rsr:
     proc ();

/*
   D_E_S_C_R_I_P_T_I_O_N_

   This command takes a resource description and reserves the
   requested resources for the calling process.  This command just
   implements the user interface.  It calls parse_resource_desc_$check
   to parse the resource description and resource_control_$reserve to
   reserve the resource.



   J_O_U_R_N_A_L_I_Z_A_T_I_O_N__

   1) Written 11/78 by R.J.C. Kissel.

*/

/* Local variables */

dcl  nargs fixed bin;
dcl  arg_ptr ptr;
dcl  arg_len fixed bin;
dcl  arg char (arg_len) based (arg_ptr);
dcl  code fixed bin (35);
dcl  info_area ptr;
dcl  err_msg char (256) varying;

/* Include Files */

%include resource_control_desc;

/* External Entries */

dcl  cu_$arg_count entry (fixed bin);
dcl  get_system_free_area_
     entry () returns (ptr);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  parse_resource_desc_$check
     entry (char (*), ptr, ptr, ptr, char (*) varying, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  resource_control_$reserve
     entry (ptr, ptr, bit (72) aligned, bit (1) aligned, fixed bin (35));

/* External Constants */

dcl  error_table_$badopt fixed bin (35) external;

/* Builtin Functions and Conditions */

dcl (null) builtin;

dcl (cleanup) condition;

	resource_desc_ptr = null ();
	resource_res_ptr = null ();
	info_area = get_system_free_area_ ();

	on cleanup
	     call Cleanup_Handler;

	call cu_$arg_count (nargs);
	if nargs ^= 2
	then goto ERROR_usage;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0
	then goto ERROR_arg;

	if arg ^= "-resource" & arg ^= "-rsc"
	then goto ERROR_carg;

	call cu_$arg_ptr (2, arg_ptr, arg_len, code);
	if code ^= 0
	then goto ERROR_arg;

	call parse_resource_desc_$check (arg, info_area, resource_desc_ptr, resource_res_ptr, err_msg, code);
	if code ^= 0
	then goto ERROR_parse;

	call resource_control_$reserve (resource_desc_ptr, resource_res_ptr, "0"b, "0"b, code);
	if code ^= 0
	then goto ERROR_res;

	return;

/*
   All error handling code goes here.
*/

ERROR_arg:
	call Cleanup_Handler ();
	call com_err_ (code, "reserve_resource");
	return;

ERROR_carg:
	call Cleanup_Handler ();
	call com_err_ (error_table_$badopt, "reserve_resource", "^a", arg);
	return;

ERROR_parse:
	call Cleanup_Handler ();
	call com_err_ (code, "reserve_resource", "^a", err_msg);
	return;

ERROR_res:
	call Cleanup_Handler ();
	call com_err_ (code, "reserve_resource", "No reservations made.");
	return;

ERROR_usage:
	call Cleanup_Handler ();
	call com_err_ (0b, "reserve_resource", "Usage: rsr -rsc resource_desc");
	return;

Cleanup_Handler:
	proc ();

	     if resource_desc_ptr ^= null ()
	     then free resource_descriptions;

	     if resource_res_ptr ^= null ()
	     then free reservation_description;

	end Cleanup_Handler;

     end reserve_resource;




		    resource_control_.pl1           11/04/82  1936.3rew 11/04/82  1618.9       26991



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


resource_control_:
     proc;

/*
   This subroutine implements the user ring interface to the resource
   control package.  All the work is done by the various entry points
   and this main procedure should never be called.
*/

/*
   Written by R.J.C. Kissel 5/78.
   Modified by R.J.C. Kissel 1/79 to call rcp_ gate and to add cancellation entry.
*/

	return;					/* To make this call a nop. */

reserve:
	entry (resource_desc_ptr, resource_res_ptr, authorization, system, code);

/*
   This entry point implements the reservation function.  It takes
   a description of the resources to be reserved, (a rservation group)
   and makes the reservation as an indivisible operation.  The code
   returned indicates success or failure and the code returned with
   each resource indicates more specifically where a failure occured.
*/

/* Arguments */

/* See the resource_control_desc include file for pointer declarations. */

dcl  authorization bit (72) aligned;			/* Only used if system = "1"b. */
dcl  system bit (1) aligned;				/* This call wishes to do a privileged reservation. */
dcl  code fixed bin (35);				/* A standard system status code. */

/* Local Variables */

/* Local Constants */

/* Local Overlays */

/* Include Files */

%include resource_control_desc;

/* External Entries */

dcl  rcp_sys_$reserve entry (ptr, ptr, bit (72) aligned, fixed bin (35));
dcl  rcp_$reserve entry (ptr, ptr, fixed bin (35));
dcl  rcp_sys_$cancel_id_string
     entry (char (*), char (*), fixed bin (35));
dcl  rcp_$cancel_id_string
     entry (char (*), fixed bin (35));

/* External Constants */

dcl  error_table_$mdc_no_access
     fixed bin (35) external;

/* Builtin Functions and Conditions */

dcl (linkage_error) condition;

	if system
	then do;					/* Check access to rcp_sys_ gate. */
	     on linkage_error
		goto BAD_ACCESS;
	     call rcp_sys_$reserve (resource_desc_ptr, resource_res_ptr, authorization, code);
	     revert linkage_error;
	end;

	else call rcp_$reserve (resource_desc_ptr, resource_res_ptr, code);

	return;

cancel_id_string:
	entry (P_res_id, P_grp_id, system, code);

dcl  P_res_id char (*) parameter;
dcl  P_grp_id char (*) parameter;
	
	if system
	then do;
	     on linkage_error
		goto BAD_ACCESS;
	     call rcp_sys_$cancel_id_string (P_res_id, P_grp_id, code);
	     revert linkage_error;
	end;

	else call rcp_$cancel_id_string (P_res_id, code);

	return;

BAD_ACCESS:
	code = error_table_$mdc_no_access;
	return;

     end resource_control_;




		    resource_status.pl1             08/06/87  1422.1rew 08/06/87  1304.7      106767



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(87-06-19,Rauschelbach), approve(87-06-29,MCR7736),
     audit(87-07-21,Farley), install(87-08-06,MR12.1-1064):
     Error message duplication was removed, and a call to com_err_ with a more
     standard version.
                                                   END HISTORY COMMENTS */


resource_status: rst: proc;

/* This command prints information about selected RCP resources.

   Written in 1979 by C. D. Tavares.
   Last modified 11/19/80 by CDT to change -usage_lock to -lock and to make
   sure it always calls the system error routine appropriate to its calling
   mode (command or AF).
   Modified 7/82 BIM to get the arg list ptr before looking at the arg list.
*/

/* automatic */

dcl  al fixed bin,
     alp pointer,
     ap pointer,
     arg_ptr entry (fixed bin, pointer, fixed bin, fixed bin (35)) variable,
     arg_ptr_rel entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer) variable,
     called_as_af bit (1) aligned,
     code fixed bin (35),
     resource_type char (32),
    (i, j, control_arg_type) fixed bin,
     nargs fixed bin,
     priv_sw bit (1) aligned,
     return_ptr pointer,
     return_len fixed bin (24);
						/* static */

dcl  registry_dir char (168) static initial (">system_control_1>rcp");

/* constants */

dcl  Name fixed bin initial (0) static options (constant);

dcl  legal_control_args (44) char (24) static options (constant) initial
    ("-priv", "FUTURE_EXP",				/* 1, 2 */
     "-unique_id", "-uid",				/* 3, 4 */
     "-potential_attributes", "-pattr",			/* 5, 6 */
     "-attributes", "-attr",				/* 7, 8 */
     "-potential_access_class", "-pacc",		/* 9, 10 */
     "-access_class", "-acc",				/* 11, 12 */
     "-owner", "-ow",				/* 13, 14 */
     "-acs_path", "FUTURE_EXP",			/* 15, 16 */
     "-location", "-loc",				/* 17, 18 */
     "-comment", "-com",				/* 19, 20 */
     "-charge_type", "-crgtp",			/* 21, 22 */
     "-mode", "-md",				/* 23, 24 */
     "-lock", "FUTURE_EXP",				/* 25, 26 */
     "-release_lock", "-rll",				/* 27, 28 */
     "-awaiting_clear", "FUTURE_EXP",			/* 29, 30 */
     "-alloc", "FUTURE_EXP",				/* 31, 32 */
    (10) (1) "FUTURE_EXP",				/* 33 thru 42 */
     "-all", "-a");					/* 43, 44 */

dcl  explanation char (168) static options (constant) initial
    ("^/^5xUsage: resource_status resource_type resource_names {control_args}");

/* external static */

dcl (error_table_$badopt,
     error_table_$badcall,
     error_table_$noarg,
     error_table_$not_act_fnc,
     error_table_$too_many_args) fixed bin (35) external static;

/* based */

dcl  arg char (al) based (ap),
     return_string char (return_len) varying based (return_ptr);

%include rst_control;

/* entries */

dcl (com_err_, active_fnc_err_) ext entry options (variable),
     cu_$af_return_arg ext entry (fixed bin, pointer, fixed bin (24), fixed bin (35)),
     cu_$arg_list_ptr ext entry (pointer),
    (cu_$arg_ptr, cu_$af_arg_ptr) ext entry (fixed bin, pointer, fixed bin, fixed bin (35)),
    (cu_$arg_ptr_rel, cu_$af_arg_ptr_rel) ext entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer),
     interpret_resource_desc_ ext entry
    (pointer, fixed bin, char (*), bit (*) aligned, bit (1) aligned, char (*) varying, fixed bin (35)),
     resource_info_$get_primary_type entry (char (*), char (*), fixed bin (35));

dcl (rcp_$get_status, rcp_admin_$get_status) ext entry (pointer, char (*), fixed bin (35));

/* builtins */

dcl (empty, hbound, index, length, null, size, string, substr, unspec) builtin;

%include resource_control_desc;

	called_as_af = ""b;
	unspec (rst_control) = ""b;
	priv_sw = ""b;

	call cu_$af_return_arg (nargs, return_ptr, return_len, code);
	if code = 0 then called_as_af = "1"b;
	else if code = error_table_$not_act_fnc then code = 0;
	if code ^= 0 then call crump (code, "Getting argument count.");

	if nargs < 2 then call crump (error_table_$noarg, explanation);

	if called_as_af then do;
	     arg_ptr = cu_$af_arg_ptr;
	     arg_ptr_rel = cu_$af_arg_ptr_rel;
	end;
	else do;
	     arg_ptr = cu_$arg_ptr;
	     arg_ptr_rel = cu_$arg_ptr_rel;
	     return_ptr = null;
	     return_len = 0;
	end;

/* First get the primary resoure type. */

	call cu_$arg_list_ptr (alp);


	call arg_ptr_rel (1, ap, al, code, alp);
	if code ^= 0
	then call crump (code, "Getting argument.");
	call resource_info_$get_primary_type (arg, resource_type, code);
	if code ^= 0
	then call crump (code, arg);

/* Next loop through the arguments and decide how many resources
   the caller wants information about. */



	Resource_count = 0;
	do i = 2 to nargs;
	     call arg_ptr (i, ap, al, code);
	     if arg = "-name" | arg = "-nm" then do;
		i = i + 1;
		Resource_count = Resource_count + 1;
	     end;
	     else if substr (arg, 1, 1) ^= "-" then
		Resource_count = Resource_count + 1;
	end;

	if Resource_count <= 0 then call crump (error_table_$noarg, explanation);

	begin;

dcl  stackarea area (size (null -> resource_descriptions) + 100) automatic;
	     stackarea = empty ();

	     allocate resource_descriptions in (stackarea);

	     resource_descriptions.version_no = resource_desc_version_1;
	     unspec (resource_descriptions.item (*)) = ""b;

	     resource_descriptions.item (*).type = resource_type;

	     Resource_count = 0;

	     do i = 2 to nargs;

		call arg_ptr_rel (i, ap, al, code, alp);

		if code ^= 0 then call crump (code, "Getting argument.");

		control_arg_type = Name;

		if arg = "-name" | arg = "-nm" then do;
		     i = i + 1;
		     call arg_ptr_rel (i, ap, al, code, alp);
		     if code ^= 0 then call crump (code, "After -name.");
		end;

		else if substr (arg, 1, 1) = "-" then do;
		     do control_arg_type = 1 to hbound (legal_control_args, 1)
			     while (legal_control_args (control_arg_type) ^= arg);
		     end;

		     if control_arg_type > hbound (legal_control_args, 1) then call crump (error_table_$badopt, arg);
		end;


		goto process_control_arg (control_arg_type);

process_control_arg (1): process_control_arg (2):		/* -priv */
		priv_sw = "1"b;
		goto end_process_control_arg;

process_control_arg (3): process_control_arg (4):		/* -unique_id, -uid */
		rst_control.uid = "1"b;
		goto end_process_control_arg;

process_control_arg (5): process_control_arg (6):		/* -potential_attributes, -pattr */
		rst_control.potential_attributes = "1"b;
		goto end_process_control_arg;

process_control_arg (7): process_control_arg (8):		/* -attributes, -attr */
		rst_control.attributes = "1"b;
		goto end_process_control_arg;

process_control_arg (9): process_control_arg (10):	/* -potential_access_class, -pacc */
		rst_control.potential_aim_range = "1"b;
		goto end_process_control_arg;

process_control_arg (11): process_control_arg (12):	/* -access_class, -acc */
		rst_control.aim_range = "1"b;
		goto end_process_control_arg;

process_control_arg (13): process_control_arg (14):	/* -owner, -ow */
		rst_control.owner = "1"b;
		goto end_process_control_arg;

process_control_arg (15): process_control_arg (16):	/* -acs_path */
		rst_control.acs_path = "1"b;
		goto end_process_control_arg;

process_control_arg (17): process_control_arg (18):	/* -location, -loc */
		rst_control.location = "1"b;
		goto end_process_control_arg;

process_control_arg (19): process_control_arg (20):	/* -comment, -com */
		rst_control.comment = "1"b;
		goto end_process_control_arg;

process_control_arg (21): process_control_arg (22):	/* -charge_type, -crgtp */
		rst_control.charge_type = "1"b;
		goto end_process_control_arg;

process_control_arg (23): process_control_arg (24):	/* -mode */
		rst_control.mode = "1"b;
		goto end_process_control_arg;

process_control_arg (25): process_control_arg (26):	/* -lock */
		rst_control.usage_lock = "1"b;
		goto end_process_control_arg;

process_control_arg (27): process_control_arg (28):	/* -release_lock, -rll */
		rst_control.release_lock = "1"b;
		goto end_process_control_arg;

process_control_arg (29): process_control_arg (30):	/* -awaiting_clear */
		rst_control.awaiting_clear = "1"b;
		goto end_process_control_arg;

process_control_arg (31): process_control_arg (32):	/* -alloc */
		rst_control.user_alloc = "1"b;
		goto end_process_control_arg;

process_control_arg (43): process_control_arg (44):	/* -all, -a */
		rst_control = "1"b;
		rst_control.given_flags, rst_control.desired_attributes = ""b;
						/* this is mostly debugging garbage */
		goto end_process_control_arg;

process_control_arg (0):				/* normal name */
		Resource_count = Resource_count + 1;
		resource_descriptions.item (Resource_count).name = arg;
		resource_descriptions.given (Resource_count).name = "1"b;

end_process_control_arg:
	     end;

	     resource_descriptions.n_items = Resource_count;

	     if called_as_af then
		if resource_descriptions.n_items > 1 then call crump (error_table_$badcall,
		     "Only one resource allowed in active function invocation.");
	     if string (rst_control) = ""b then
		string (rst_control) = rst_control_defaults; /* default, name, attributes, mode, and user_free */

	     if called_as_af then do;
		j = index (string (rst_control), "1"b);
		if j = 0 then call crump (error_table_$noarg, "Desired return value not specified.");
		if j ^= length (string (rst_control)) then
		     if substr (string (rst_control), j+1) ^= ""b then
			call crump (error_table_$too_many_args, "Cannot return more than one resource property in active function invocation.");
	     end;

Process (6):					/* Status */
	     if priv_sw then
		call rcp_admin_$get_status (resource_desc_ptr, registry_dir, code);
	     else call rcp_$get_status (resource_desc_ptr, registry_dir, code);
	     if code ^= 0 then do;

		do i = 1 to resource_descriptions.n_items while (resource_descriptions.item (i).status_code = 0);
		end;

		if i > resource_descriptions.n_items then
		     call crump (code, "Cannot obtain status from ring 1.");
		else do;
		     if ^called_as_af then do;
			call com_err_ (resource_descriptions.item (i).status_code,
			     "resource_status", "^a ^a", resource_descriptions.item (i).type,
			     resource_descriptions.item (i).name);
		     end;
		     else do;
			call active_fnc_err_ (resource_descriptions.item (i).status_code,
			     "resource_status", "^a ^a", resource_descriptions.item (i).type,
			     resource_descriptions.item (i).name);
			return_string = "";
			goto return_hard;
		     end;
		end;
	     end;

	     else call interpret_resource_desc_ (resource_desc_ptr, 0, "resource_status",
		string (rst_control), called_as_af, return_string, code);
						/* ignore code, err msg has already been printed */
	end;					/* begin block */

	return;
	
crump:	proc (code, message);

dcl  code fixed bin (35),
     message char (*);

	     if called_as_af then do;
		call active_fnc_err_ (code, "resource_status", message, "resource_status");
		return_string = "";
	     end;
	     else call com_err_ (code, "resource_status", message, "resource_status");
	     goto return_hard;
	end crump;

return_hard: return;
	
test:	entry (newdir);

dcl  newdir char (*) parameter;

	if newdir = "" then registry_dir = ">system_control_1>rcp";
	else registry_dir = newdir;
	return;

     end resource_status;




		    unassign_resource.pl1           02/16/84  1523.3r   02/16/84  1522.4       94635



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


unassign_resource: ur: procedure;

/*	This program is a command that may be called to unassign a resource controled by RCP.
   *	Created on 01/10/75 by Bill Silver.
   *	Changed on 03/30/75 by Bill Silver to add "device" option.
   *	Modified on 12/09/78 by Michael R. Jordan for version 3 list info.
   *	Modified 2/80 by Michael R. Jordan to add -all
   *	Modified 12/12/83 by Jim Lippard to remove "all".
   *
   *	In the current implementation this command can unassign only devices.
   *	Its calling sequence is:
   *
   *	unassign_resource, ur [resource] [-control_args]
   *
   *	resource		Specifies the resource to be unassigned.
   *			A user may unassign any device by specifying its name.
   *
   *	The following optional control arguments are also supported:
   *
   *	(-com | -comment)	The value argument is a comment that will be displayed
   *			to the operator when the device is unassigned.  If more
   *			than one term is required they should be in quotes.
   *	(-am  | -admin)	Indicates that a force unassignment is to be done.
   *			The user must have access to the gate rcp_sys_.
   *	(-a | -all)	Indicates that all resources are to be unassigned.
*/

/*		AUTOMATIC  DATA		*/

dcl  pointers (1) ptr;				/* Pointer array for temp segment manager. */

dcl  admin_flag bit (1);				/* ON => we must do a force unassignment. */
dcl  all_sw bit (1);				/* ON => unassign all resources */
dcl  arg_len fixed bin;				/* Length of an argument string. */
dcl  arg_ptr ptr;					/* Pointer to an argument string. */
dcl  argx fixed bin;				/* Number of the current argument. */
dcl  comment char (64);				/* Comments to and from operator. */
dcl  device_name char (32);				/* Name of device to be unassigned. */
dcl  ecode fixed bin (35);				/* error_table_ code. */
dcl  i fixed bin;
dcl  num_args fixed bin;				/* Number of command arguments. */
dcl  num_unassigned fixed bin;			/* Number of devices unassigned. */
dcl  option char (12);				/* Command option string. */
dcl  seg_size fixed bin (19);				/* Max size of temp segment. */


/*		BASED  DATA		*/

dcl  argument char (arg_len) based (arg_ptr);		/* Used to reference argument string. */


/*		INTERNAL STATIC DATA	*/

dcl  brief_options (3) char (4)			/* Brief form of command options. */
     internal static init ("-com", "-am", "-a");

dcl  long_options (3) char (8)			/* Long  form of command options. */
     internal static init ("-comment", "-admin", "-all");

dcl  HAS_VALUE (3) bit (1) unal internal static options (constant) init ("1"b, "0"b, "0"b);

/*		EXTERNAL ENTRIES CALLED	*/

dcl  cleanup condition;

dcl (addr, hbound, null, substr) builtin;

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

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  get_temp_segments_ entry (char (*), (1) ptr, fixed bin (35));
dcl  hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl  rcp_$copy_list entry (ptr, fixed bin (19), fixed bin (35));
dcl  rcp_$unassign entry (bit (36) aligned, bit (*), char (*), fixed bin (35));
dcl  rcp_sys_$unassign_device entry (char (*), fixed bin (35));
dcl  release_temp_segments_ entry (char (*), (1) ptr, fixed bin (35));

%include rcp_list_info;

/*	Begin command:  unassign_resource
*/
	ecode,					/* Initialize. */
	     num_unassigned = 0;
	comment,
	     device_name = " ";
	admin_flag = "0"b;				/* Assume no admin unassignment. */
	all_sw = "0"b;				/* not -all */

	call cu_$arg_count (num_args);		/* Total number of command arguments. */

	if num_args < 1				/* Was any device specified? */
	then do;					/* No, no argument. */
NO_RESOURCE:   call com_err_ (error_table_$noarg, "unassign_resource", "No resource specified.");
	     return;
	end;

	call cu_$arg_ptr (1, arg_ptr, arg_len, ecode);	/* Get resource name. */
	if ecode ^= 0
	then do;
	     call com_err_ (ecode, "unassign_resource", "Error getting resource name argument.");
	     return;
	end;

	if substr (argument, 1, 1) ^= "-"		/* Make sure that it is not a control argument. */
	then do;
	     argx = 2;
	     device_name = argument;
	end;
	else argx = 1;

	do argx = argx to num_args;			/* Process any optional control arguments. */
	     call PROCESS_ARG;			/* Most will be processed in pairs. */
	     if ecode ^= 0				/* Was there an error? */
	     then return;				/* Yes, abort. */
	end;

	if device_name ^= ""
	& all_sw then do;
	     call com_err_ (error_table_$inconsistent, "unassign_resource", "Cannot specify resource name and -all.");
	     return;
	end;

	if device_name = ""
	& ^all_sw
	then goto NO_RESOURCE;

	if admin_flag				/* Does user want to force the unassignment? */
	then do;					/* Yes. */
	     if all_sw
	     then do;
		call com_err_ (error_table_$inconsistent, "unassign_resource", "Cannot specify -admin and -all together.");
		return;
	     end;
	     call rcp_sys_$unassign_device (device_name, ecode);
	     if ecode ^= 0
	     then call com_err_ (ecode, "unassign_resource", "Error force unassigning ^a.", device_name);
	     return;
	end;

/*	User wants to unassign one or more devices from her/his process.
   *	Get temporary segment for RCP list info structure.
   *	Set up cleanup handler to release temp segment.
*/
	pointers (1) = null ();
	on cleanup begin;
	     if pointers (1) ^= null ()
	     then call release_temp_segments_ ("unassign_resource", pointers, ecode);
	end;

	call get_temp_segments_ ("unassign_resource", pointers, ecode);
	if ecode ^= 0				/* Unable to get temporary working segment? */
	then do;					/* Yes. */
	     call com_err_ (ecode, "unassign_resource", "Error getting temporary segment.");
	     return;
	end;

	call hcs_$get_max_length_seg (pointers (1), seg_size, ecode);
	if ecode ^= 0				/* We need max size of temp segment. */
	then do;
	     call com_err_ (ecode, "unassign_resource", "Error getting maximum length of temporary segment.");
	     goto RETURN;
	end;

	rli_ptr = pointers (1);			/* Temp segment used to RCP info. */
	rli.version_num = rli_version_4;

	call rcp_$copy_list (rli_ptr, seg_size, ecode);
	if ecode ^= 0				/* Error copying process's RCP info? */
	then do;					/* Yes. */
	     call com_err_ (ecode, "unassign_resource", "Error copying RCP info from lower ring.");
	     goto RETURN;
	end;

	do i = 1 to rli.head.num_dassign;		/* Look at each assigned device. */
	     dassign_ptr = addr (rli.dassigns (i));	/* Get pointer to assignment entry. */
	     if all_sw |				/* Unassigning all devices? */
	     (device_name = dassign.device_name)	/* Or this device? */
	     then do;				/* Yes, unassign this device. */
		num_unassigned = num_unassigned + 1;
		call rcp_$unassign (dassign.rcp_id, "0"b, comment, ecode);
		if ecode ^= 0
		then call com_err_ (ecode, "unassign_resource", "Error unassigning ^a.", dassign.device_name);
		comment = " ";			/* Issue comment only once. */
	     end;
	end;

	if num_unassigned = 0			/* Did we unassign any devices? */
	then if all_sw				/* No. */
	     then call com_err_ (error_table_$resource_unassigned, "unassign_resource", "No resources assigned.");
	     else call com_err_ (error_table_$resource_unassigned, "unassign_resource", "^a", device_name);

RETURN:						/* Come here to release temp  segment. */
	call release_temp_segments_ ("unassign_resource", pointers, ecode);
	if ecode ^= 0
	then call com_err_ (ecode, "unassign_resource", "Error releasing temporary segment.");

	return;
						/* 	*/
PROCESS_ARG: procedure;

/*	This procedure is called to process one option argument.
   *	All of the option arguments except "-admin" have a value argument.
   *	This value must be the next argument.  In this case we will process
   *	the value argument too.
*/
	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "unassign_resource", "Error getting argument ^d.", argx);
		return;
	     end;

	     option = argument;			/* Save option argument. */

	     do i = 1 to hbound (brief_options, 1);	/* Look for valid option name. */
		if (option = brief_options (i)) |	/* Is it this brief name? */
		(option = long_options (i))		/* Or this long name. */
		then do;				/* Yes, one of them. */
		     if HAS_VALUE (i)
		     then do;
			call GET_VALUE;		/* Get accompanying value argument. */
			if ecode ^= 0		/* Check for errors. */
			then return;
		     end;
		     goto OPTION (i);		/* Go process this option. */
		end;
	     end;

	     ecode = error_table_$badopt;		/* Option not found. */
	     call com_err_ (ecode, "uasssign_resource", "^a", option);
	     return;

OPTION (1):					/* "-com" or "-comment" */
	     comment = argument;			/* Save user's comment to operator. */
	     return;

OPTION (2):					/* "-am" or "-admin" */
	     admin_flag = "1"b;			/* We want to unassign through privileged gate. */
	     return;

OPTION (3):					/* "-a" or "-all" */

	     all_sw = "1"b;
	     return;

	end PROCESS_ARG;
						/* 	*/
GET_VALUE: procedure;

/*	This procedure is called to get the value argument that is associated
   *	with the current option argument.
*/
	     if argx = num_args			/* Is this the last argument? */
	     then do;				/* Yes, value argument missing. */
		ecode = error_table_$noarg;
		call com_err_ (ecode, "unassign_resource", "No value argument for ^a.", option);
		return;
	     end;

	     argx = argx + 1;			/* Move to the next argument. */

	     call cu_$arg_ptr (argx, arg_ptr, arg_len, ecode);
	     if ecode ^= 0
	     then do;
		call com_err_ (ecode, "unassign_resource", "Error getting argument ^d.", argx);
		return;
	     end;

	     if substr (argument, 1, 1) = "-"		/* Is next argument a control option? */
	     then do;				/* Yes, value argument is missing. */
		ecode = error_table_$noarg;
		call com_err_ (ecode, "unassign_resource", "No value argument for ^a.", option);
		return;
	     end;

	end GET_VALUE;


     end unassign_resource;




		    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
