



		    cv_rcp_attributes_.pl1          11/11/89  1110.3rew 11/11/89  0806.7      157374



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

/****^  format: off */

cv_rcp_attributes_: proc; return;

/* This subroutine changes RCP attribute specifications into printable RCP
   attribute descriptions and vice versa.  Multiple entrypoints allow
   these operations, as well as several perversions on the same theme. */
/* Written 04/02/78 by C. D. Tavares */
/* Last modified 02/27/80 by CDT to add make_rel entry. */


/****^  HISTORY COMMENTS:
  1) change(87-07-15,Rauschelbach), approve(87-08-07,MCR7748),
     audit(87-11-11,Farley), install(87-11-30,MR12.2-1004):
     Set RTDT_area_len.
                                                   END HISTORY COMMENTS */


%include rtdt;

/* automatic */

dcl  temp_spec bit (72) aligned,
     temp_relatts (4) bit (72),
     temp_atts (2) bit (72),
     temp_att_string char (256) varying;

/* static */

dcl  sysdir char (168) initial (">system_control_1") static;
dcl  sys_info$max_seg_size fixed bin (35) ext static;

/* entries */

dcl  hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin, fixed bin, pointer, fixed bin (35)),
     hcs_$terminate_noname ext entry (pointer, fixed bin (35));

dcl  sub_err_ ext entry options (variable);



/* external variables */

dcl (error_table_$rcp_bad_attributes,
     error_table_$unimplemented_version,
     error_table_$resource_type_inappropriate,
     error_table_$resource_unknown) ext fixed bin (35) static;

/* builtins */

dcl (pointer, substr, index, max, null, copy, length, rtrim, string, size) builtin;

dcl  cleanup condition;
	
to_string: entry (resource_type, attributes, attribute_string, code);

dcl (resource_type char (*),
     attributes (2) bit (72),
     attribute_string char (*) varying,
     code fixed bin (35)) parameter;

	rtdtp = null;

	RTDT_area_len = 0;				/* With the area size 0, then rtdt is only as
						   big as the header info. */
	RTDT_area_len = sys_info$max_seg_size - size (rtdt);


	on cleanup call term_rtdt (0);

	call find_rtde (resource_type, code);
	if code ^= 0 then return;

	call make_string (attributes, attribute_string, code);

	call term_rtdt (code);
	return;
	
to_string_rel: entry (resource_type, rel_attributes, attribute_string, code);

dcl  rel_attributes (4) bit (72) parameter;

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call find_rtde (resource_type, code);
	if code ^= 0 then return;

	call make_string_rel (rel_attributes, attribute_string, code);

	if code ^= 0 then call term_rtdt (0);
	else call term_rtdt (code);
	return;
	
to_string_given_rtde: entry (xrtdep, attributes, attribute_string, code);

/* This entry is for the use of display_rtdt only. */

dcl  xrtdep pointer parameter;

	rtdep = xrtdep;

	call make_string (attributes, attribute_string, code);
	return;
	
from_string: entry (resource_type, attributes, attribute_string, code);

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call find_rtde (resource_type, code);
	if code ^= 0 then return;

	call interpret_string (attribute_string, temp_relatts, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	attributes (1) = temp_relatts (1);
	attributes (2) = temp_relatts (2);

	call term_rtdt (code);
	return;
	
from_string_rel: entry (resource_type, rel_attributes, attribute_string, code);

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call find_rtde (resource_type, code);
	if code ^= 0 then return;

	call interpret_string (attribute_string, rel_attributes, code);
	if code ^= 0 then call term_rtdt (0);
	else call term_rtdt (code);
	return;
	
modify:	entry (resource_type, attributes, attribute_string, new_attributes, code);

dcl  new_attributes (2) bit (72) parameter;

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call find_rtde (resource_type, code);
	if code ^= 0 then return;

	call interpret_string (attribute_string, temp_relatts, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	new_attributes (1) = (attributes (1) | rel_attributes (1)) & ^rel_attributes (3);
	new_attributes (2) = (attributes (2) | rel_attributes (2)) & ^rel_attributes (4);

	call term_rtdt (code);
	return;
	
make_rel:	entry (resource_type, attributes, rel_attributes, code);

/* This entry takes a full or relative attribute string in absolute attribute
   format and makes a full relative attribute string in relative attribute
   format (filling in the "turn off" bit portions).  It does this via the
   quick and dirty method of converting back and forth to a char string. */

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call find_rtde (resource_type, code);
	if code ^= 0 then return;

	call check_validity (attributes, validity_level, code);
	if code ^= 0 then do;
term_and_return:
	     call term_rtdt (0);
	     return;
	end;

	call make_string (attributes, temp_att_string, code);
	if code ^= 0 then goto term_and_return;

	call interpret_string (temp_att_string, rel_attributes, code);
	if code ^= 0 then goto term_and_return;

	call term_rtdt (code);
	return;
	
modify_rel: entry (attributes, rel_attributes, new_attributes);

	new_attributes (1) = (attributes (1) | rel_attributes (1)) & ^rel_attributes (3);
	new_attributes (2) = (attributes (2) | rel_attributes (2)) & ^rel_attributes (4);
	return;
	
test_valid: entry (resource_type, attributes, validity_level, code);

dcl  validity_level fixed bin parameter;

dcl (Absolute initial (0),
     Relative initial (1),
     Multiple initial (2),
     Invalid initial (3)) fixed bin static options (constant);

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call find_rtde (resource_type, code);
	if code ^= 0 then return;

	call check_validity (attributes, validity_level, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	call term_rtdt (code);
	return;
	
protected_change: entry (attributes, rel_attributes) returns (bit (1) aligned);

	if (rel_attributes (2) & attributes (2)) ^= rel_attributes (2) then
	     return ("1"b);				/* making a currently unprotected attribute protected */
	if (rel_attributes (4) & ^attributes (2)) ^= rel_attributes (4) then
	     return ("1"b);				/* making a currently protected attribute unprotected */
	if (rel_attributes (3) & attributes (2)) ^= "0"b then
	     return ("1"b);				/* turning off a currently protected attribute */

	return ("0"b);				/* this will cause no change to protected attributes */
	
reduce_implications: entry (vol_type, vol_attributes, dev_type, dev_attributes, code);

dcl ((vol_type, dev_type) char (*),
    (vol_attributes, dev_attributes) dimension (2) bit (72)) parameter;

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call find_rtde (vol_type, code);
	if code ^= 0 then return;

	if ^rtde.is_volume then do;
	     code = error_table_$resource_type_inappropriate;
	     call term_rtdt (0);
	     return;
	end;

	if rtde.n_mates ^= 1 then do;
	     code = error_table_$resource_unknown;
	     call term_rtdt (0);
	     return;
	end;

	dev_type = rtde.mates (1);

	temp_atts (1) = vol_attributes (1) & string (rtde.attributes_to_match);
	temp_atts (2) = ""b;

	call make_string (temp_atts, temp_att_string, code);

	call term_rtdt (0);
	if code ^= 0 /* from make_string */ then return;

	call find_rtde (dev_type, code);
	if code ^= 0 then return;

	call interpret_string (temp_att_string, temp_relatts, code);

	call term_rtdt (0);
	if code ^= 0 /* from interpret_string */ then return;

	dev_attributes (1) = temp_relatts (1);
	dev_attributes (2) = temp_relatts (2);

	return;


find_rtde: proc (resource_type_arg, code);

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

dcl  resource_type char (32),
     i fixed bin,
     found bit (1) aligned,
     error_table_$improper_data_format ext fixed bin (35) static;

	     call hcs_$initiate (sysdir, "rtdt", "", 0, 0, rtdtp, code);
	     if rtdtp = null then do;
		call sub_err_ (code, "cv_rcp_attributes_", "c", null, 0, "Cannot initiate ^a>rtdt", sysdir);
		return;
	     end;
	     code = 0;

	     if (rtdt.version ^= RTDT_version_2) & (rtdt.version ^= RTDT_version_3) then do;
		code = error_table_$unimplemented_version;
		call hcs_$terminate_noname (rtdtp, 0);
		return;
	     end;

	     resource_type = resource_type_arg;

	     do i = 1 to 2;				/* give 2 chances to chase down 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
			if rtde.name = resource_type then
			     if ^rtde.is_synonym then return;
			     else do;
				resource_type = rtde.syn_to;
				found = "1"b;
			     end;
		end;

		if ^found then do;
		     code = error_table_$resource_unknown;
		     call hcs_$terminate_noname (rtdtp, 0);
		     return;
		end;
	     end;

	     code = error_table_$improper_data_format;
	     call hcs_$terminate_noname (rtdtp, 0);
	     return;

	end find_rtde;
	
term_rtdt: proc (code);

dcl  code fixed bin (35) parameter;
	     if rtdtp ^= null then
		call hcs_$terminate_noname (rtdtp, code);
	     return;

	end term_rtdt;
	
make_string: proc (abs_attributes, attribute_string, code);

dcl (abs_attributes (2) bit (72),
     attribute_string char (*) varying,
     code fixed bin (35)) parameter;

dcl (i, j) fixed bin,
     auto_attributes (4) bit (72);

	     string (auto_attributes) = string (abs_attributes);
	     goto make_string_common;

make_string_rel: entry (rel_attributes, attribute_string, code);

dcl  rel_attributes (4) bit (72);

	     string (auto_attributes) = string (rel_attributes);
	     goto make_string_common;

make_string_common:
	     attribute_string = "";

	     do i = index (auto_attributes (1), "1"b) repeat (i) while (i > 0);
		if i > rtde.n_defined_attributes then do;
		     code = error_table_$rcp_bad_attributes;
		     return;
		end;

		if substr (rtde.attributes_valid, i, 1) = "1"b then do;
		     attribute_string = attribute_string || rtrim (rtde.attribute_names (i), " ");
		     if substr (auto_attributes (2), i, 1) then attribute_string = attribute_string || "*,";

		     else attribute_string = attribute_string || ",";
		end;

		if substr (auto_attributes (1), i+1) = ""b then i = -1;
		else i = i + index (substr (auto_attributes (1), i+1), "1"b);
	     end;

	     do i = index (auto_attributes (3), "1"b) repeat (i) while (i > 0);
		if i > rtde.n_defined_attributes then do;
		     code = error_table_$rcp_bad_attributes;
		     return;
		end;

		if substr (rtde.attributes_valid, i, 1) = "0"b then do;
		     code = error_table_$rcp_bad_attributes;
		     return;
		end;

/* this may be on because "key=val" is ON in the first string, so all other values of "key=" must
   be turned OFF.  This is simple to check for, because "key=" values never appear in the third
   element otherwise (you can't say "^key=val"!) */

		do j = 1 to rtde.n_exclusion_specs while
			(substr (rtde.exclusion_specs (j), i, 1) = "0"b);
		end;

		if j > rtde.n_exclusion_specs then do;
		     attribute_string = attribute_string || "^";
		     attribute_string = attribute_string || rtrim (rtde.attribute_names (i), " ");
		     attribute_string = attribute_string || ",";
		end;

		if substr (auto_attributes (3), i+1) = ""b then i = -1;
		else i = i + index (substr (auto_attributes (3), i+1), "1"b);
	     end;

	     do i = index (auto_attributes (4), "1"b) repeat (i) while (i > 0);
		if i > rtde.n_defined_attributes then do;
		     code = error_table_$rcp_bad_attributes;
		     return;
		end;

		if substr (rtde.attributes_valid, i, 1) = "0"b then do;
		     code = error_table_$rcp_bad_attributes;
		     return;
		end;

		if substr (rel_attributes (3), i, 1) = "0"b then /* already printed if so */
		     if substr (rel_attributes (1), i, 1) = "0"b then do;
						/* ditto */
			attribute_string = attribute_string || rtrim (rtde.attribute_names (i), " ");
			attribute_string = attribute_string || ",";
		     end;

		if substr (auto_attributes (4), i+1) = ""b then i = -1;
		else i = i + index (substr (auto_attributes (4), i+1), "1"b);
	     end;

	     if length (attribute_string) > 0 then
		attribute_string = substr (attribute_string, 1, length (attribute_string) - 1);

	     code = 0;
	     return;
	end make_string;
	
check_validity: proc (attributes, validity_level, code);

dcl (attributes (2) bit (72),
     validity_level fixed bin parameter,
     code fixed bin (35)) parameter;

dcl (i, j) fixed bin;

	     validity_level = Absolute;		/* for now, anyway */

/* All bits should be within limits */

	     if substr (attributes (1), rtde.n_defined_attributes+1) ^= ""b then do;
badatt:		code = error_table_$rcp_bad_attributes;
		validity_level = Invalid;
		return;
	     end;

/* Protected attributes must be subset of current attributes */

	     if (attributes (1) & attributes (2)) ^= attributes (2) then goto badatt;

/* Enabled attributes must be subset of potential attributes */

	     if (attributes (1) & string (rtde.attributes_valid)) ^= attributes (1) then goto badatt;

/* Now check to see that one and only one of each "key=val" attributes is on. */

	     do i = 1 to rtde.n_exclusion_specs;

		temp_spec = exclusion_specs (i) & attributes (1);

		j = index (temp_spec, "1"b);

		if j = 0 then validity_level = max (validity_level, Relative);
		else if j < length (temp_spec) then
		     if substr (temp_spec, j+1) ^= ""b then validity_level = max (validity_level, Multiple);
	     end;

	     code = 0;				/* congratulations, you passed */
	     return;

	end check_validity;
	
interpret_string: proc (attribute_string, relatts, code);

dcl (attribute_string char (*) varying,
     relatts (4) bit (72),
     code fixed bin (35)) parameter;

dcl  single_attr char (12) varying,
    (i, j, k) fixed bin,
    (protected, not) bit (1) aligned,
     temp_spec bit (72) aligned;

/* A relative attribute string consists of four bit (72) quantities.
   The first represents the attributes that were specified to be ON.
   The second represents the attributes that were specified as PROTECTED.
   The third represents the attributes that must be turned OFF, either as the
   result of the user specifying "^attr", or having "key=val" specified
   such that all other possible "key=valN" must be forced off.
   The fourth represents the attributes that must be NONPROTECTED, either as the
   result of the user specifying "attr", or having "key=val" or "key=val*" specified
   such that all other possible "key=valN must be DEPROTECTED. */

/* An absolute attribute string consists of the first two of these quantities
   which are always a consistent combination of attributes. */

	     i = 1;
	     relatts (*) = ""b;

	     do while (i <= length (attribute_string));

		j = index (substr (attribute_string, i), ",") - 1;
		if j = -1 then j = length (substr (attribute_string, i));

		single_attr = substr (attribute_string, i, j);
		single_attr = rtrim (single_attr, " "); /* PL/I won't do this correctly in one stmt right now. */
		if substr (single_attr, 1, 1) = "^" then do;

		     if index (single_attr, "=") > 0 then do; /* "^key=val" makes no sense--
						   you turn one of those off by turning another on. */
			code = error_table_$rcp_bad_attributes;
			return;
		     end;

		     single_attr = copy (substr (single_attr, 2), 1);
		     not = "1"b;
		end;

		else not = ""b;

		if substr (single_attr, length (single_attr), 1) = "*" then do;
		     if not then do;		/* "^mumble*" ?? */
			code = error_table_$rcp_bad_attributes;
			return;
		     end;
		     single_attr = substr (single_attr, 1, length (single_attr) - 1);
		     protected = "1"b;
		end;

		else protected = ""b;

		do k = 1 to rtde.n_defined_attributes while ((rtde.attribute_names (k) ^= single_attr)
			| (substr (rtde.attributes_valid, k, 1) = "0"b));
		end;

		if k > rtde.n_defined_attributes then do;
		     code = error_table_$rcp_bad_attributes;
		     return;
		end;

		if not then substr (relatts (3), k, 1) = "1"b;
		else substr (relatts (1), k, 1) = "1"b;

		if protected then substr (relatts (2), k, 1) = "1"b;
		else substr (relatts (4), k, 1) = "1"b;

		i = i + j + 1;
	     end;

/* Perform exclusions to turn off all other values of "key=a" */

	     do i = 1 to rtde.n_exclusion_specs;

		if (rtde.exclusion_specs (i) & relatts (1)) ^= ""b then do;
						/* One of these exclusive attributes has been mentioned */
		     temp_spec = rtde.exclusion_specs (i) & ^relatts (1) & rtde.attributes_valid;
						/* last operand necc. due to bug in early vers. of up_rtdt_ */
		     relatts (3) = relatts (3) | temp_spec; /* turn OFF matching keys */
		     relatts (4) = relatts (4) | temp_spec; /* and their protected counterparts */
		end;
	     end;

	     return;
	end interpret_string;
	
test:	entry (newsysdir);

dcl  newsysdir char (*);

	if newsysdir = "" then sysdir = ">system_control_1";
	else sysdir = newsysdir;
	return;

     end cv_rcp_attributes_;




		    rcp_access_kernel_.pl1          11/11/89  1110.3r w 11/11/89  0804.3       77274



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_access_kernel_:
     procedure (a_operation, a_requestor_info_ptr, a_resource_info_ptr, a_effmode, a_code);

/*     This program implements an access kernel for RCP
   *     Created 841024 by Maria M. Pozzo
   *
   *     The operation argument is used to determine the access rules
   *     to apply when calculating effective access of the user to
   *     the RCP resource.
*/


/****^  HISTORY COMMENTS:
  1) change(85-07-08,Pozzo), approve(86-02-21,MCR7346), audit(86-07-29,Farley),
     install(86-08-01,MR12.0-1108):
     Modified to return the correct error code from rcp_compute_bracket_mode.
  2) change(85-07-10,Pozzo), approve(86-02-21,MCR7346), audit(86-07-29,Farley),
     install(86-08-01,MR12.0-1108):
     Modified to audit attempt to access a multi-class volume from outside ring
     1 or without the rcp privilege turned on.
  3) change(86-08-07,Farley), approve(86-08-07,MCR7469),
     audit(86-10-19,Beattie), install(86-10-28,MR12.0-1200):
     Added validation level check for MCA attachments.
                                                   END HISTORY COMMENTS */


/*                    ARGUMENT DATA                           */

dcl	a_operation	   bit (36) aligned;	/* (I) RCP operation found in rcp_operations.incl.pl1 */
dcl	a_requestor_info_ptr   ptr;			/* (I) Contains information about the user requesting the RCP operation */
dcl	a_resource_info_ptr	   ptr;			/* (I) Contains information about the resource being requested */
dcl	a_effmode		   bit (3);		/* (O) Effective access mode of the requesting user to the RCP resource */
dcl	a_code		   fixed bin (35);		/* (O) Error code */

/*                    AUTOMATIC                            */

dcl	rcp_priv		   bit (1) aligned;		/* ON => rcp system_privilege is enabled */
dcl	rm_on		   bit (1) aligned;		/* Set if Resource Management is enabled */
dcl	(aim_mode, bracket_mode, effmode, raw_mode, temp_effmode)
			   bit (3);		/* access modes */
dcl	operation		   bit (36) aligned;
dcl	base_operation	   bit (36) aligned;

dcl	acs_path		   char (168);		/* ACS pathname */
dcl	owner		   char (32);		/* If RM is enabled this is the resource owner found in the registry */
dcl	who_am_i		   char (32);		/* Identifies this program. */

dcl	operation_ptr	   ptr;			/* RCP operation */

dcl	error_code	   fixed bin (35);		/* Internal error code */
dcl	input_code	   fixed bin (35);		/* Passed in error_code */
dcl	rbs		   (2) fixed bin (3);	/* Ring brackets of the ACS if it exists. */

dcl	1 en_access_op	   like encoded_access_op aligned based (operation_ptr);

dcl	addr		   builtin;

/*                    CONSTANTS                               */

dcl	RING_1		   fixed bin (3) static internal options (constant) init (1);

/*                    EXTERNAL                                */

dcl	error_table_$bad_ring_brackets
			   fixed bin (35) external;
dcl	error_table_$unsupported_multi_class_volume
			   fixed bin (35) external;

/*                    EXTERNAL ENTRIES                        */


dcl	rcp_audit		   entry (char (*), bit (36) aligned, ptr, ptr, char (*), bit (3), bit (3),
			   (2) fixed bin (3), bit (1), fixed bin (35));
dcl	rcp_merge_modes	   entry (bit (3), bit (3), fixed bin (35)) returns (bit (3));
dcl	rcp_access_kernel_setup
			   entry (bit (36) aligned, ptr, ptr, bit (1) aligned, char (168), bit (1) aligned,
			   char (32), bit (3), fixed bin (35));
dcl	rcp_compute_aim_mode   entry (ptr, ptr, bit (3), fixed bin (35));
dcl	rcp_compute_bracket_mode
			   entry (char (168), ptr, ptr, bit (3), (2) fixed bin (3), fixed bin (35));
dcl	rcp_compute_raw_mode   entry (bit (1) aligned, ptr, ptr, char (168), char (32), bit (3), fixed bin (35));
dcl	rcp_operation_access   entry (bit (36) aligned, char (32), bit (1) aligned, bit (3), fixed bin (35));
dcl	access_operations_$rcp_acquire
			   bit (36) aligned external;
dcl	access_operations_$rcp_register
			   bit (36) aligned external;
dcl	access_operations_$rcp_register_acquire
			   bit (36) aligned external;
%page;
/*  Copy input arguments */

	operation = a_operation;
	base_operation = operation;
	input_code = a_code;
	addr (base_operation) -> encoded_access_op.detailed_operation = 0;
	operation_ptr = addr (operation);
	requestor_info_ptr = a_requestor_info_ptr;
	resource_info_ptr = a_resource_info_ptr;

/*  Initializer local variables */

	who_am_i = "rcp_access_kernel_";
	rcp_priv, rm_on = "0"b;
	aim_mode, bracket_mode, effmode, raw_mode = ""b;
	temp_effmode = REW_ACCESS;
	owner = "";
	ops_ptr = addr (en_access_op.detailed_operation);
	error_code = 0;
	rbs = 0;
	rbs (1) = -1;				/* In case they don't exist. */

/*  Get setup - determine if this is a privileged user */

	call rcp_access_kernel_setup (operation, requestor_info_ptr, resource_info_ptr, rm_on, acs_path, rcp_priv,
	     owner, effmode, error_code);

	if error_code ^= 0 then
	     if error_code = error_table_$unsupported_multi_class_volume then
		goto AUDIT;
	     else goto MAIN_RETURN;

	if base_operation = access_operations_$rcp_register | base_operation = access_operations_$rcp_register_acquire
	     | base_operation = access_operations_$rcp_acquire then
	     goto MAIN_RETURN;			/* These ops have default access and are audited later. */

	if effmode ^= ""b then			/* Some operations have default access but get audited now. */
	     goto AUDIT;

/*  If the resource is an MCA, verify that the requestor's validation level is correct. */

	if resource_info.resource_type = DEVICE_TYPE (MCA_DTYPEX) then
	     if requestor_info.validation_level > RING_1 then do;
		error_code = error_table_$bad_ring_brackets;
		goto AUDIT;
	     end;
	     else ;
	else ;

/*  If this is a privileged gate call (rcp_sys_, rcp_admin_) bypass all discretionary access checks */

	if ^detailed_operation.priv_gate_call then do;

/*  Calculate the discretionary access mode of the subject to the object */

	     call rcp_compute_raw_mode (rm_on, requestor_info_ptr, resource_info_ptr, acs_path, owner, raw_mode,
		error_code);

/*  Calculate the ring bracket mode - if the acs path is null then
   this check is bypassed */

	     if acs_path ^= "" then do;
		call rcp_compute_bracket_mode (acs_path, requestor_info_ptr, resource_info_ptr, bracket_mode, rbs,
		     error_code);

/*  Determine the temporary effective mode without AIM factored in */

		temp_effmode = rcp_merge_modes (raw_mode, bracket_mode, error_code);

	     end;
	     else temp_effmode = raw_mode;

	end;

/*  If RM is enabled and RCP system privilege is off, must factor in the AIM access mode */

	if (rm_on & ^rcp_priv) then do;
	     call rcp_compute_aim_mode (requestor_info_ptr, resource_info_ptr, aim_mode, error_code);
	     effmode = rcp_merge_modes (temp_effmode, aim_mode, error_code);
	end;
	else effmode = temp_effmode;

/*  Now we know the access, see if we have enough to perform the requested operation */

	call rcp_operation_access (operation, resource_info.resource_type, rm_on, effmode, error_code);
	a_code = error_code;

/* Now let's audit the attempted operation. rcp_audit determines if auditing */
/* is enabled. */

AUDIT:
/**** If the error code passed in is not zero, then the operation failed due
      to reasons other than access (such as resource locked) and this call to
      the access kernel is to determine how much information to return.  We
      want to be sure to audit this as a denial of the operation even though
      the user may have access. */
	if input_code ^= 0 then
	     call rcp_audit (who_am_i, operation, requestor_info_ptr, resource_info_ptr, owner, ("000"b), raw_mode, rbs,
		(rm_on), (error_code));
	else call rcp_audit (who_am_i, operation, requestor_info_ptr, resource_info_ptr, owner, (effmode), raw_mode,
		rbs, (rm_on), (error_code));

MAIN_RETURN:
	a_operation = operation;
	a_effmode = effmode;
	a_code = error_code;
	return;
%page;
%include access_audit_encoded_op;
%page;
%include access_mode_values;
%page;
%include rcp_ops;
%page;
%include rcp_resource_info;
%page;
%include rcp_resource_types;
%page;
%include rcp_requestor_info;

     end rcp_access_kernel_;





		    rcp_access_kernel_setup.pl1     11/11/89  1110.3rew 11/11/89  0804.6       98685



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */

rcp_access_kernel_setup:
     procedure (a_operation, a_requestor_info_ptr, a_resource_info_ptr, a_rm_on, a_acs_path, a_rcp_priv, a_owner,
	a_effmode, a_error_code);

/*     This program implements the set up procedures for the RCP
   *     access kernel.
   *     Created 841108 by Maria M. Pozzo
   *     Modified 850401 by E. Swenson to protect pointer reference by
   *       rm_on flag.
   *
   *     This routine determines if a valid operation was requested,
   *     if Resource Management (RM) is enabled, the registry directory if
   *     there is one, if the rcp privilege is enabled, if the Initializer
   *     has made the call (Initializer gets REW), the resource owner
   *     if there is one and some general setup.
*/


/****^  HISTORY COMMENTS:
  1) change(87-07-14,Rauschelbach), approve(87-08-07,MCR7748),
     audit(87-11-11,Farley), install(87-11-30,MR12.2-1004):
     Removed signal to vfile_error condition as it was erroneously left in from
     debugging.
                                                   END HISTORY COMMENTS */


/*                    ARGUMENT DATA                          */

dcl	a_operation	   bit (36) aligned;	/* (I) RCP operation */
dcl	a_requestor_info_ptr   ptr;			/* (I) Requestor information */
dcl	a_resource_info_ptr	   ptr;			/* (I) Resource information */
dcl	a_rm_on		   bit (1) aligned;		/* (O) ON-> Resource Management enabled */
dcl	a_acs_path	   char (168);		/* (O) Pathnameof the ACS segment */
dcl	a_rcp_priv	   bit (1) aligned;		/* (O) ON->the rcp system priviege is enabled */
dcl	a_owner		   char (32);		/* (O) Resouce owner if one exists */
dcl	a_effmode		   bit (3);		/* (O) Some operations have a default effmode */
dcl	a_error_code	   fixed bin (35);		/* (O) Error code */

/*                  AUTOMATIC DATA                       */

dcl	based_bits	   bit (bl * 9) aligned based (bp);
dcl	device_found	   bit (1) aligned;		/* Locates the device in rcp_data */
dcl	device_off	   bit (18) aligned;	/* Offset to device entry in rcp_data */
dcl	is_volume		   bit (1);		/* True if resource is a volume. */
dcl	rcp_priv		   bit (1) aligned;		/* rcp privilege on */
dcl	rm_on		   bit (1) aligned;		/* Resource_management enabled */
dcl	effmode		   bit (3);
dcl	object_access_class	   (2) bit (72) aligned;
dcl	operation		   bit (36) aligned;
dcl	base_operation	   bit (36) aligned;
dcl	acs_path		   char (168);		/* Pathname of the ACS segment */
dcl	based_charstring	   char (bl) aligned based (bp);
dcl	owner		   char (32);		/* Owner name if one exists */
dcl	temp_user_id	   char (32);
dcl	prim_resource_type	   char (32);		/* Hold the primary resource type */

dcl	bl		   fixed bin (21);
dcl	error_code	   fixed bin (35);		/* Local error code */
dcl	(i, loc)		   fixed bin;		/* Working variable */

dcl	bp		   ptr;
dcl	operation_ptr	   ptr;

dcl	1 en_access_op	   like encoded_access_op aligned based (operation_ptr) aligned;

/*                   EXTERNAL ENTRIES                       */

dcl	aim_check_$equal	   entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	pathname_		   entry (char (*), char (*)) returns (char (168));
dcl	rcp_pointers_$data	   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	access_operations_$rcp_register
			   bit (36) aligned external;
dcl	access_operations_$rcp_register_acquire
			   bit (36) aligned external;
dcl	access_operations_$rcp_acquire
			   bit (36) aligned external;
dcl	access_operations_$rcp_cancel
			   bit (36) aligned external;

/*                  ERROR ENTRIES                           */

dcl	error_table_$unsupported_multi_class_volume
			   fixed bin (35) external;
dcl	error_table_$resource_unknown
			   fixed bin (35) external;
dcl	error_table_$action_not_performed
			   fixed bin (35) external;

dcl	(addr, hbound, length, null, ptr, rtrim, substr, unspec)
			   builtin;

/*                     CONSTANTS                       */

dcl	DEFAULT_REGISTRY_DIR   char (64) internal static options (constant) init (">sc1>rcp");

%page;


/*  Copy arguments */

	operation = a_operation;
	base_operation = operation;
	addr (base_operation) -> encoded_access_op.detailed_operation = 0;
	operation_ptr = addr (operation);
	requestor_info_ptr = a_requestor_info_ptr;
	resource_info_ptr = a_resource_info_ptr;
	record_ptr = resource_info.registry_record_ptr;

/*  Initialize local variables */

	device_found, rm_on, rcp_priv = "0"b;
	device_off = (18)"0"b;
	prim_resource_type, owner = "";
	acs_path = "";
	i, loc, bl = 0;
	error_code = 0;
	bp = null ();
	effmode = ""b;
	ops_ptr = addr (en_access_op.detailed_operation);

/* Determine if Resource Management enabled */

	rcpd_ptr = rcp_pointers_$data ();
	if rcpd.modes.resource_mgmt_enabled then
	     rm_on = "1"b;
	else rm_on = "0"b;

/* Set Registry and rcp priv flag */

	if rm_on then
	     if (resource_info.registry_dir = "") then
		resource_info.registry_dir = DEFAULT_REGISTRY_DIR;

	if addr (requestor_info.current_authorization) -> aim_template.privileges.rcp then
	     rcp_priv = "1"b;
	else rcp_priv = "0"b;

/*  If it's a Register operation then there is no owner or registry */
/*  yet so no need to continue just give REW access.  */
/*  if it's an acquire operation, as long as it is a free resource  */
/*  which is checked outside the kernel, then it can be acquired. */
/*  If it's a cancel operation, as long as this is the user who */
/*  made the reservation, or it was a privileged user (which are both */
/*  checked outside the kernel) then it can be cancelled. */

	if base_operation = access_operations_$rcp_register | base_operation = access_operations_$rcp_register_acquire
	     | base_operation = access_operations_$rcp_acquire | base_operation = access_operations_$rcp_cancel then do;
	     effmode = REW_ACCESS;
	     owner = "free";
	     goto MAIN_RETURN;
	end;

/*  If the resource is not free and it is a volume, see if it is */
/*  a multi-class volume.  We can not handle multi-class volumes unless */
/*  we are executing in ring 1 OR the user has the rcp privilege enabled. */
/*  Otherwise, no one has access to multi-class volumes not even the */
/*  Initializer. */

	call resource_info_$get_primary_type (resource_info.resource_type, prim_resource_type, error_code);
	if error_code ^= 0 then
	     goto MAIN_RETURN;
	call resource_info_$get_type (prim_resource_type, is_volume, error_code);
	if error_code ^= 0 then
	     goto MAIN_RETURN;

	if rm_on then
	     if (is_volume & ^registry_record.free & requestor_info.validation_level ^= 1 & ^rcp_priv) then do;
		call chase (registry_record.aim_range_desc, bp, bl, error_code);
		if error_code ^= 0 then
		     goto MAIN_RETURN;
		if bl > 0 then
		     addr (object_access_class) -> based_bits = based_bits;
		else unspec (object_access_class) = ""b;/* no range, set to lowest possible */
		if ^aim_check_$equal (object_access_class (1), object_access_class (2)) then do;
		     error_code = error_table_$unsupported_multi_class_volume;
		     goto MAIN_RETURN;
		end;
	     end;

/*  If it is the Initializer, just give REW access. */

	if requestor_info.user_id = "Initializer.SysDaemon.z" then do;
	     effmode = REW_ACCESS;
	     goto MAIN_RETURN;
	end;

/*  Let's get the owner if it exists */
/*  Set the owner bit in the operation if this user is the owner. */

	if rm_on then do;
	     call chase (registry_record.owner_desc, bp, bl, error_code);
	     if error_code ^= 0 then
		goto MAIN_RETURN;
	     owner = based_charstring;
	     temp_user_id = substr (requestor_info.user_id, 1, length (rtrim (requestor_info.user_id)) - 2);
	     detailed_operation.owner = (owner = temp_user_id);
	end;

/*  Let's get the ACS segment pathname if it exists */

	if rm_on then do;
	     if registry_record.acs_path_desc ^= 0 then do;
		call chase (registry_record.acs_path_desc, bp, bl, error_code);
		if error_code ^= 0 then
		     goto MAIN_RETURN;
		acs_path = based_charstring;
	     end;
	end;
	else do;
	     if ^is_volume then
		do i = 1 to hbound (DEVICE_TYPE, 1);
		if prim_resource_type = DEVICE_TYPE (i) then do;
		     device_found = "0"b;
		     do device_off = rcpd.dtype (i).first_off repeat device.next_off
			while ((device_off ^= (18)"0"b) & ^device_found);
			device_ptr = ptr (rcpd_ptr, device_off);
			if device.device_name = resource_info.resource_name then
			     device_found = "1"b;
		     end;
		     if ^device_found then
			error_code = error_table_$resource_unknown;
		     else if rm_on then
			acs_path = pathname_ ((resource_info.registry_dir), (device.acs_name));
		     else acs_path = pathname_ (DEFAULT_REGISTRY_DIR, (device.acs_name));
		     goto MAIN_RETURN;
		end;
	     end;
	end;

/*  If this is a priv_gate call then DAC access check is by_passed, and */
/*  if the rcp privilege is enabled then AIM access check is by_passed; */
/*  so if both are true just give REW. */

	if (detailed_operation.priv_gate_call & rcp_priv) then
	     effmode = REW_ACCESS;


MAIN_RETURN:
	a_operation = operation;
	a_rm_on = rm_on;
	a_acs_path = acs_path;
	a_owner = owner;
	a_rcp_priv = rcp_priv;
	a_effmode = effmode;
	a_error_code = error_code;

%page;
chase:
     proc (descriptor, bp, bl, a_error_code);

dcl	(
	descriptor	   fixed bin (35),
	a_error_code	   fixed bin (35),
	bp		   pointer,
	bl		   fixed bin (21)
	)		   parameter;

dcl	1 rs		   like rs_info aligned automatic;
dcl	local_code	   fixed bin (35);

	a_error_code = 0;
	if descriptor = 0 then do;
	     bp = addr (bp);			/* gotta point somewhere */
	     bl = 0;
	     return;
	end;

	unspec (rs) = ""b;
	rs.version = rs_info_version_2;
	rs.locate_sw = "1"b;
	rs.descriptor = descriptor;
	local_code = 0;

	call iox_$control (resource_info.registry_switch_ptr, "record_status", addr (rs), local_code);
	if local_code ^= 0 then do;
	     a_error_code = error_table_$action_not_performed;
	     return;
	end;
	bl = rs.record_length;
	bp = rs.record_ptr;

	return;
     end chase;
%page;
%include access_audit_encoded_op;
%page;
%include access_mode_values;
%page;
%include aim_template;
%page;
%include iox_dcls;
%page;
%include rcp_com_seg;
%page;
%include rcp_data;
%page;
%include rcp_ops;
%page;
%include rcp_registry;
%page;
%include rcp_requestor_info;
%page;
%include rcp_resource_types;
%page;
%include rcp_resource_info;
%page;
%include rs_info;

     end rcp_access_kernel_setup;




		    rcp_assign_device_.pl1          11/11/89  1110.3r   11/11/89  0805.9       55098



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_assign_device_:
     procedure (arg_device_type, arg_device_info_ptr, arg_event_id, arg_comment, arg_rcp_id, arg_ecode);

/*	This program implements the rcp_$assign_device entry point.
   *	Created on 11/20/74 by Bill Silver.
   *
   *	This program is called to assign one device class resource.  We will allocate one
   *	RCS entry of this assignment request.  We will fill in this entry with all
   *	of the data needed to make this assignment.  If there are no errors we will call
   *	rcp_control_
   *	to perform the actual device assignment.  The results of this call will not
   *	be tested until a call is made to rcp_$check_assign.
*/
/*        Modified 841005 to interface to rcp_control_ instead of
   *          rcp_initializer...M.M.Pozzo
   *        Modified 850131 as part of the B2 effort...M. M. Pozzo
   *	Modified 850304 to copy device_info correctly...Chris Jones
*/

/*		ARGUMENT  DATA		*/

dcl	arg_device_type	   char (*);		/* (I) Type of device being assigned. */
dcl	arg_comment	   char (*);		/* (I) Caller's comment. */
dcl	arg_device_info_ptr	   ptr;			/* (I) Pointer to device info structure. */
dcl	arg_ecode		   fixed bin (35);		/* (O) error_table_ code. */
dcl	arg_event_id	   fixed bin (71);		/* (I) Caller's event channel ID. */
dcl	arg_rcp_id	   bit (36) aligned;	/* (O) ID for this assignment request. */


/*		AUTOMATIC  DATA		*/


dcl	device_info_buffer	   (RCP_MAX_DEVICE_INFO_SIZE) bit (36) aligned;
dcl	device_offset	   bit (18) aligned init ("0"b);
						/* Offset to device entry passed to rcp_control_. */
dcl	process_id	   bit (36) aligned init ("0"b);
						/* Process id of process making the request */
dcl	rcp_id		   bit (36) aligned;	/* ID that identifies RCS entry. */
dcl	rcse_off		   bit (18);		/* Offset to RCS entry. */
dcl	volume_offset	   bit (18) aligned init ("0"b);
						/* Offset to volume entry passed to rcp_control_. */

dcl	device_name	   char (32) init ("");	/* Device name */
dcl	device_type	   char (32);		/* Device type name. */
dcl	operation		   bit (36) aligned;	/* Type of operation being requested by RCP */

dcl	prev_level	   fixed bin;		/* Caller's validation level. */
dcl	ecode		   fixed bin (35);		/* error_table_ code. */
dcl	error_count	   fixed bin (17) init (0);	/* Input to rcp_control_ for attachment errors */
dcl	1 rcse_buffer	   like rcse aligned;	/* Template RCSE. */

/*		EXTERNAL ENTRIES CALLED	*/

dcl	cleanup		   condition;		/* Used to set up cleanup handler. */

dcl	(addr, rel)	   builtin;

dcl	error_table_$resource_assigned
			   fixed bin (35) external;

dcl	access_operations_$rcp_assign_write
			   bit (36) ext static;

dcl	cu_$level_get	   entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	get_ring_		   entry returns (fixed bin);
dcl	rcp_control_	   entry (bit (36) aligned, bit (18) aligned, bit (18) aligned, char (*), fixed bin (17),
			   bit (36) aligned, fixed bin (35));
dcl	rcp_device_info_$copy  entry (char (*), ptr, ptr, fixed bin (35));
dcl	rcp_device_info_$get   entry (char (*), ptr, ptr, fixed bin, fixed bin (35));
dcl	rcp_find_$device	   entry (char (*) aligned, bit (18));
dcl	rcp_rcse_$get	   entry (ptr, fixed bin (35));

	call cu_$level_get (prev_level);		/* Save caller's validation level. */
	on cleanup
	     begin;				/* If trouble cleanup. */
	     call cu_$level_set (prev_level);
	end;
	call cu_$level_set (get_ring_ ());		/* Set validation level to RCP level. */

	rcse_off,					/* No RCS entry or rcp_id yet. */
	     rcp_id = "0"b;
	device_type = arg_device_type;		/* Get type of device being assigned. */
	device_info_ptr = arg_device_info_ptr;		/* copy the caller's device_info structure */
	call rcp_device_info_$copy (device_type, device_info_ptr, addr (device_info_buffer), ecode);
	if ecode ^= 0 then
	     goto RETURN;
	device_info_ptr = addr (device_info_buffer);

	rcse_ptr = addr (rcse_buffer);		/* Use template RCSE. */

	call rcp_device_info_$get (device_type, device_info_ptr, rcse_ptr, prev_level, ecode);
	if ecode ^= 0 then
	     goto RETURN;

/* Fill in the rest of the RCSE. */
	rcse.kind = 2;				/* This is an assignment RCSE. */
	rcse.disposition = "1"b;			/* Explicit assignment => retain. */
	rcse.event_id = arg_event_id;			/* Save argument data. */
	rcse.caller_comment = arg_comment;

	if rcse.flags.device			/* Are we assigning a specific device? */
	then do;					/* Yes, see if already assigned to this process. */
	     call rcp_find_$device (rcse.device_name, rcse_off);
	     if rcse_off ^= "0"b			/* Is it already assigned? */
	     then do;				/* Yes. */
		ecode = error_table_$resource_assigned;
		goto RETURN;
	     end;
	end;

	call rcp_rcse_$get (rcse_ptr, ecode);		/* Now get a real assignment RCSE. */
	if ecode ^= 0 then
	     goto RETURN;
	rcse_off = rel (rcse_ptr);			/* Save offset of RCSE. */
	rcp_id = rcse.rcp_id;			/* Get real RCP ID. */

/* Now call rcp_control_ to assign a device. */
	operation = access_operations_$rcp_assign_write;
	volume_offset = "0"b;
	device_offset = rcse_off;
	device_name = rcse.device_name;
	call rcp_control_ (operation, volume_offset, device_offset, device_name, error_count, process_id, ecode);

RETURN:
	arg_rcp_id = rcp_id;			/* Set return arguments. */
	arg_ecode = ecode;
	call cu_$level_set (prev_level);		/* Reset validation level to caller level. */

%include rcp_com_seg;
%page;
%include rcp_device_info_structs;

     end rcp_assign_device_;




		    rcp_attach_.pl1                 11/11/89  1110.3rew 11/11/89  0804.3       94698



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

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */

rcp_attach_:
     procedure;

/*	This program is called to attach a device controlled by RCP.
   *
   *	This program has the following entry points:
   *	  1.  priv_attach	-  Attach a device with privilege.
   *	  2.  attach	-  Attach a device.
*/
/*
   *	Created on 11/21/74 by Bill Silver.
   *      Modified 841009 to interface with rcp_control_ instead of
   *         rcp_initializer_... - M. M. Pozzo
*/

/****^  HISTORY COMMENTS:
  1) change(85-06-27,Pozzo), approve(86-02-21,MCR7346),
     audit(86-07-29,Farley), install(86-08-01,MR12.0-1108):
     Modified to return a good error code when a garbage error code was input.
  2) change(85-07-18,CLJones), approve(86-02-21,MCR7346),
     audit(86-07-29,Farley), install(86-08-01,MR12.0-1108):
     Modified to not return rcp_id when an error is encountered.
  3) change(85-07-21,ABall), approve(86-02-21,MCR7346),
     audit(86-07-29,Farley), install(86-08-01,MR12.0-1108):
     Modified to check for null rcse_ptr and arcse_ptr before referencing
     rcse_off.
  4) change(85-09-11,Fawcett), approve(85-09-11,MCR6979),
     audit(85-12-02,CLJones), install(86-03-21,MR12.0-1033):
     Add MCA and FIPS support
                                                   END HISTORY COMMENTS */

/*		ARGUMENT  DATA		*/

dcl	arg_comment	   char (*);		/* (I) Caller's comment. */
dcl	arg_device_info_ptr	   ptr;			/* (I) Pointer to device info structure. */
dcl	arg_device_type	   char (*);		/* (I) Device type name. */
dcl	arg_ecode		   fixed bin (35);		/* (O) error_table_ code. */
dcl	arg_event_id	   fixed bin (71);		/* (I) Caller's event channel ID. */
dcl	arg_rcp_id	   bit (36) aligned;	/* (O) ID for this attachment request. */


/*		AUTOMATIC  DATA		*/


dcl	arcse_off		   bit (18);		/* Offset  of assignment RCS entry. */
dcl	device_off	   bit (18) aligned;	/* Offset of RCS entry specifying device. */
dcl	priv_flag		   bit (1);		/* ON => privileged attach. */
dcl	process_id	   bit (36) aligned;	/* Needed by rcp_control_ */
dcl	rcse_off		   bit (18);		/* Offset of RCS entry. */
dcl	volume_off	   bit (18) aligned;	/* Offset of RCS entry specifying volume. */
dcl	got_arcse		   bit (1) aligned;		/* whether we acquired an arcse */
dcl	got_rcse		   bit (1) aligned;		/* whether we acquired an rcse */

dcl	device_type	   char (32);		/* Device type name. */
dcl	device_name	   char (32);		/* Needed by rcp_control_. */
dcl	operation		   bit (36) aligned;	/* Operation being requested of rcp_control_. */

dcl	caller_level	   fixed bin;		/* Caller's validation level. */
dcl	ecode		   fixed bin (35);		/* error_table_ code. */
dcl	error_count	   fixed bin (17);		/* Error count for device attachments */

dcl	arcse_ptr		   ptr;			/* Pointer to assignment RCS entry. */
dcl	callers_device_info_ptr
			   ptr;
dcl	device_info_buffer	   (RCP_MAX_DEVICE_INFO_SIZE) bit (36) aligned;
dcl	1 rcse_buffer	   like rcse aligned;	/* Template RCSE. */

/*		BASED  DATA		*/

dcl	1 arcse		   based (arcse_ptr) like rcse aligned;
						/* Used to reference assignment RCS entry. */


/*		EXTERNAL ENTRIES CALLED	*/

dcl	cleanup		   condition;		/* Used to establish cleanup handler. */

dcl	(addr, null, ptr, rel) builtin;

dcl	(
	error_table_$bad_volid,
	error_table_$no_operation,
	error_table_$resource_attached
	)		   fixed bin (35) external;

dcl	access_operations_$rcp_assign_write
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_assign_read
			   bit (36) aligned ext static;

dcl	cu_$level_get	   entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	get_ring_		   entry returns (fixed bin);
dcl	rcp_find_$attached	   entry (ptr, bit (18));
dcl	rcp_find_$unattached   entry (ptr, bit (18));
dcl	rcp_control_	   entry (bit (36) aligned, bit (18) aligned, bit (18) aligned, char (*), fixed bin (17),
			   bit (36) aligned, fixed bin (35));
dcl	rcp_device_info_$copy  entry (char (*), ptr, ptr, fixed bin (35));
dcl	rcp_device_info_$get   entry (char (*), ptr, ptr, fixed bin, fixed bin (35));
dcl	rcp_device_info_$set   entry (pointer, pointer, fixed bin (35));
dcl	rcp_rcse_$free	   entry (ptr, fixed bin (35));
dcl	rcp_rcse_$get	   entry (ptr, fixed bin (35));

priv_attach:
     entry (arg_device_type, arg_device_info_ptr, arg_event_id, arg_comment, arg_rcp_id, arg_ecode);


	priv_flag = "1"b;
	goto COMMON;


attach:
     entry (arg_device_type, arg_device_info_ptr, arg_event_id, arg_comment, arg_rcp_id, arg_ecode);


	priv_flag = "0"b;


COMMON:
	device_off = ""b;
	process_id = ""b;
	volume_off = ""b;
	device_name = "";
	error_count = 0;
	rcse_ptr, arcse_ptr = null ();
	got_arcse, got_rcse = "0"b;

	call cu_$level_get (caller_level);		/* Save caller's validation level. */
	on cleanup call CLEANUP (error_table_$no_operation);

	call cu_$level_set (get_ring_ ());		/* Set validation level to RCP level. */

	device_type = arg_device_type;		/* Get device type name. */
	callers_device_info_ptr = arg_device_info_ptr;
	device_info_ptr = addr (device_info_buffer);
	call rcp_device_info_$copy (device_type, callers_device_info_ptr, device_info_ptr, ecode);
	if ecode ^= 0 then
	     goto RETURN;
	rcse_ptr = addr (rcse_buffer);		/* Use temporary RCSE. */

	call rcp_device_info_$get (device_type, device_info_ptr, rcse_ptr, caller_level, ecode);
	if ecode ^= 0 then
	     goto RETURN;

/* Fill in the rest of the RCSE. */
	rcse.kind = 1;				/* This is an attachment RCSE. */
	rcse.flags.priv = priv_flag;			/* Remember if privileged attachment. */
	rcse.event_id = arg_event_id;			/* Save argument data. */
	rcse.caller_comment = arg_comment;

	goto DEVICE_TYPE (rcse.dtypex);		/* Special tests based upon device type. */


DEVICE_TYPE (1):					/* TAPE */
DEVICE_TYPE (2):					/* DISK */
	if ^rcse.flags.volume			/* Was a volume specified? */
	then do;					/* No, but it is required. */
	     ecode = error_table_$bad_volid;
	     goto RETURN;
	end;
	if (rcse.flags.t_and_d) &			/* Is attachment for a T&D volume? */
	     (^priv_flag)				/* Then is this a privileged attachment? */
	then do;					/* No, T&D must use privileged entry. */
	     ecode = error_table_$no_operation;
	     goto RETURN;
	end;


DEVICE_TYPE (3):					/* CONSOLE */
DEVICE_TYPE (4):					/* PRINTER */
DEVICE_TYPE (5):					/* PUNCH */
DEVICE_TYPE (6):					/* READER */
DEVICE_TYPE (7):					/* SPECIAL */
DEVICE_TYPE (8):					/* MCA */
/****	If we are attaching a specific device or if we are attaching a volume
      *	then we must check to see if that device or volume is already attached
      *	to this process.
****/
	if (rcse.flags.device) |			/* Attaching a specific device? */
	     (rcse.flags.volume)			/* Or attaching a volume. */
	then do;					/* Yes. */
	     call rcp_find_$attached (rcse_ptr, arcse_off);
	     if arcse_off ^= "0"b			/* Already attached? */
	     then do;				/* Yes. */
		ecode = error_table_$resource_attached;
		goto RETURN;
	     end;
	end;

/*	Now get a real attachment RCSE.  All the data in our temporary RCSE will
   *	be copied into the real RCSE.
*/
	call rcp_rcse_$get (rcse_ptr, ecode);
	if ecode ^= 0 then
	     goto RETURN;
	got_rcse = "1"b;
	rcse_off = rel (rcse_ptr);

/*	Now we must see if an appropriate (and unattached) device is already
   *	assigned to this process.  If so we will use that device.  Otherwise
   *	we will have to have rcp_control_ assign a device.
*/
	call rcp_find_$unattached (rcse_ptr, arcse_off);
	if arcse_off ^= "0"b			/* Did we find an assigned unattached device? */
	then do;					/* Yes, use it. */
	     device_off = "0"b;			/* We don't need to assign a device. */
	     arcse_ptr = ptr (rcse_ptr, arcse_off);
	end;
	else do;					/* No, must assign a device. */
	     arcse_ptr = addr (rcse_buffer);		/* Use attachment RCSE as template. */
	     arcse.kind = 2;			/* Show that this is an assignment RCSE. */
	     call rcp_rcse_$get (arcse_ptr, ecode);
	     if ecode ^= 0 then			/* Any error getting assignment RCS entry? */
		goto RETURN;			/* Yes, free attachment RCSE. */
	     got_arcse = "1"b;
	     arcse_off = rel (arcse_ptr);		/* Now we have an assignment RCS entry. */
	     device_off = arcse_off;			/* Assign device through assignment RCS entry. */
	end;

	arcse.rcse_off = rcse_off;			/* Link the attach and assign RCSEs. */
	rcse.rcse_off = arcse_off;

	if rcse.flags.volume			/* Is there a volume? */
	     then
	     volume_off = rcse_off;			/* Yes, assign it using attachment RCSE. */
	else do;					/* No volume to assign. */
	     volume_off = "0"b;
	     rcse.state = 2;			/* State => any volume assignment has been done. */
	end;

	if (device_off ^= "0"b) |			/* Do we have to assign a device? */
	     (volume_off ^= "0"b)			/* Or a volume? */
	then do;					/* Yes, something to assign. */
	     if volume_off ^= "0"b & ^rcse.flags.writing then
		operation = access_operations_$rcp_assign_read;
	     else operation = access_operations_$rcp_assign_write;
	     call rcp_control_ (operation, volume_off, device_off, device_name, error_count, process_id, ecode);
	     if ecode = 0 then
		call rcp_device_info_$set (callers_device_info_ptr, rcse_ptr, (0));
	     /*** in case the name has changed (from "scratch") ***/
	     /*** we ignore the code since it's the caller's problem,
		and the attachment has been made in any case. ***/
	end;

RETURN:
	call CLEANUP (ecode);
	if ecode = 0 then
	     arg_rcp_id = rcse.rcp_id;
	arg_ecode = ecode;
	return;

CLEANUP:
     proc (code);

dcl	code		   fixed bin (35);

	if code ^= 0 then do;
	     if rcse_ptr ^= null () then
		rcse.rcse_off = ""b;
	     if arcse_ptr ^= null () then
		arcse.rcse_off = ""b;
	     if got_arcse then
		call rcp_rcse_$free (arcse_ptr, (0));
	     if got_rcse then
		call rcp_rcse_$free (rcse_ptr, (0));
	end;
	call cu_$level_set (caller_level);

     end CLEANUP;

%include rcp_com_seg;
%page;
%include rcp_device_info_structs;

     end rcp_attach_;




		    rcp_attach_lv_.pl1              11/11/89  1110.3rew 11/11/89  0805.2       56556



/****^  ***********************************************************
        *                                                         *
        * 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(85-07-10,EJSharpe), approve(86-02-20,MCR7304),
     audit(86-03-27,CLJones), install(86-04-23,MR12.0-1044):
     added security auditing
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_attach_lv_:
     procedure (arg_volume_info_ptr, arg_event_id, arg_rcp_id, arg_ecode);

/*	This program implements the rcp_$attach_lv entry point.
   *	Created on 06/08/76 by Bill Silver.
   *	Moddfied 09/13/76 by Bernard Greenberg for lv_request_.
   *	Modified 84-09-04 by EJ Sharpe - rename hdx refs to volume_registration_mgr_
   *	Modified 84-10-30 by EJ Sharpe - new volume_registration_mgr_$get_access uses bit(36) instead of fixed(5)
   *	Modified 12/84 by Chris Jones for B2 security cleanup.
*/

/*
   *	This program is called to attach one logical volume.
   *	The volume must be registered and this process must have RW access to it.
   *	The program rcp_lv_ will be call to add this lv to a list of lvs
   *	that are attached for this process.  The lv will be attached by rcp_attach_lv_.
   Calls to rcp$check_attach_lv interrogate the global table.
*/

/*		ARGUMENT  DATA		*/

dcl	arg_volume_info_ptr	   ptr;			/* (I) Pointer to logical volume info structure. */
dcl	arg_event_id	   fixed bin (71);		/* (I) Caller's event channel ID. */
dcl	arg_rcp_id	   bit (36) aligned;	/* (0) ID for this logical volume attachment. */
dcl	arg_ecode		   fixed bin (35);		/* (O) error_table_ code. */

/*		AUTOMATIC  DATA		*/

dcl	access		   bit (36) aligned;	/* Access mode to logical volume. */
dcl	1 auto_event_flags	   aligned like audit_event_flags;
dcl	1 auto_lv_info	   aligned like lv_info;	/* local copy of lv info */
dcl	caller_level	   fixed bin;		/* Caller's validation level. */
dcl	ecode		   fixed bin (35);		/* error_table_ code. */
dcl	event_id		   fixed bin (71);		/* Caller's event channel ID */
dcl	lvid		   bit (36) aligned;	/* ID that identifies logical volume. */
dcl	lv_access_range	   (2) bit (72) aligned;	/* access range of volume */
dcl	pub_bit		   bit (1) aligned;		/* from volume_registration_mgr_$get_access - we ignore it */
dcl	rcp_id		   bit (36) aligned;	/* ID for this attach request. */

/*		EXTERNAL ENTRIES CALLED	*/

dcl	access_operations_$attach_lv
			   bit (36) aligned external;
dcl	error_table_$resource_assigned
			   fixed bin (35) external;
dcl	error_table_$resource_bad_access
			   fixed bin (35) external;
dcl	error_table_$unimplemented_version
			   fixed bin (35) external;

dcl	access_audit_r1_$log_obj_class_range
			   entry options (variable);
dcl	cu_$level_get	   entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	get_ring_		   entry () returns (fixed bin (3));
dcl	volume_registration_mgr_$find_lvid
			   entry (char (*), bit (36) aligned, fixed bin (35));
dcl	volume_registration_mgr_$get_access_for_attach
			   entry (char (*), fixed bin, bit (36) aligned, bit (1) aligned, (2) bit (72) aligned,
			   fixed bin (35));
dcl	rcp_lv_$add_lv	   entry (char (*) aligned, bit (36) aligned, fixed bin (71), bit (36) aligned,
			   fixed bin (35));

/*	Builtins and conditions	*/

dcl	addr		   builtin;
dcl	null		   builtin;
dcl	string		   builtin;

dcl	cleanup		   condition;

/*	Begin rcp_attach_lv_ */

	call cu_$level_get (caller_level);		/* Save caller's validation level. */

	on cleanup call cu_$level_set (caller_level);

	call cu_$level_set (get_ring_ ());		/* Set validation level to RCP level. */

	rcp_id = "0"b;				/* Initialize RCP ID (rcp_id). */
	event_id = arg_event_id;			/* Copy caller's event channel */

	lv_info_ptr = addr (auto_lv_info);
	lv_info = arg_volume_info_ptr -> lv_info;	/* copy lv_info structure */
	if lv_info.version_num ^= rlvi_version_1 then do; /* Wrong version of lv info structure. */
	     ecode = error_table_$unimplemented_version;
	     goto RETURN;
	end;

	call volume_registration_mgr_$find_lvid ((lv_info.volume_name), lvid, ecode);
	if ecode ^= 0 then
	     goto RETURN;				/* Volume is not registered. */

	/*** here's the decision whether to proceed with the attach.  This
	     code really should be in an "lv_access_kernel_" */

	string (auto_event_flags) = ""b;
	call volume_registration_mgr_$get_access_for_attach ((lv_info.volume_name), caller_level, access, pub_bit,
	     lv_access_range, ecode);
	if ecode ^= 0 then do;
	     call audit_it;
	     goto RETURN;				/* Error getting access to volume. */
	end;

	if (access & RW_ACCESS) ^= RW_ACCESS then do;	/* Caller does not have RW access to volume. */
	     ecode = error_table_$resource_bad_access;
	     call audit_it;
	     goto RETURN;
	end;
	else do;
	     auto_event_flags.grant = "1"b;
	     call audit_it;
	end;

	call rcp_lv_$add_lv (lv_info.volume_name, lvid, event_id, rcp_id, ecode);
	if ecode ^= 0				/* Error adding lv to per-process list? */
	     then
	     if ecode = error_table_$resource_assigned then
		ecode = 0;			/* Ok if already attached. */


RETURN:
	arg_rcp_id = rcp_id;			/* Set return arguments. */
	arg_ecode = ecode;
	call cu_$level_set (caller_level);		/* Reset validation level to caller level. */
	return;

audit_it:
     procedure ();

dcl	volname_str	   char (64);

	volname_str = "logical volume " || lv_info.volume_name;

	call access_audit_r1_$log_obj_class_range ("rcp_attach_lv_", caller_level, string (auto_event_flags),
	     access_operations_$attach_lv, lv_access_range, volname_str, ecode, null (), (0));
	return;

     end audit_it;

%include access_mode_values;
%page;
%include rcp_lv_info;
%page;
%include access_audit_eventflags;

     end rcp_attach_lv_;




		    rcp_audit.pl1                   11/11/89  1110.3rew 11/11/89  0806.7      109719



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_audit:
     procedure (a_caller, a_operation, a_req_info_ptr, a_res_info_ptr, a_owner, a_effmode, a_raw_mode, a_rbs, a_rm_on,
	a_error_code);

/*            This internal subroutine determines if auditing is
   *	    required for an RCP event.
   *            Created 841112 by Maria M. Pozzo
   *
*/


/****^  HISTORY COMMENTS:
  1) change(87-07-14,Rauschelbach), approve(87-08-07,MCR7748),
     audit(87-11-11,Farley), install(87-11-30,MR12.2-1004):
     Removed signal to vfile_error condition as it was erroneously left from
     debugging.
                                                   END HISTORY COMMENTS */


/*            ARGUMENTS                       */

dcl	a_caller		   char (*);		/* (I) Identifies the program that made the call. */
dcl	a_operation	   bit (36) aligned;	/* (I) The RCP operation as defined in rcp_operations.incl.pl1 */
dcl	a_req_info_ptr	   ptr;			/* (I) Pointer to requestor information. */
dcl	a_res_info_ptr	   ptr;			/* (I) Pointer to object information. */
dcl	a_owner		   char (*);		/* (I) Resource Owner. */
dcl	a_effmode		   bit (3);		/* (I) "0"b3 if access was denied */
dcl	a_raw_mode	   bit (3);		/* (I) Raw mode used in auditing. */
dcl	a_rbs		   (2) fixed bin (3);	/* (I) Ring brackets of the ACS segment if there was one. */
dcl	a_rm_on		   bit (1);		/* (I) True = resource management enabled */
dcl	a_error_code	   fixed bin (35);		/* (I) Error code */

/*            AUTOMATIC                       */

dcl	audit		   bit (1);		/* Is audit needed. */
dcl	1 auto_rcp_obj_info	   like rcp_obj_info;
dcl	based_bits	   bit (bl * 9) aligned based (bp);
dcl	rm_on		   bit (1);
dcl	effmode		   bit (3);
dcl	raw_mode		   bit (3);
dcl	rbs		   (2) fixed bin (3);
dcl	object_access_class	   (2) bit (72) aligned;
dcl	event_flags	   bit (36) aligned;
dcl	operation		   bit (36) aligned;	/* Local operation */
dcl	base_op		   bit (36) aligned;	/* oper_code for audit. */

dcl	caller		   char (32);		/* Local caller */
dcl	msg_str		   char (256);		/* Format string for audit message. */
dcl	object_name	   char (177);		/* Object name is "Registry " plus the pathname of the registry, at it's largest. */
dcl	owner		   char (32);		/* Current resource owner. */
dcl	registry_dir	   char (168);		/* directory registry is contained in */
dcl	registry_name	   char (32);		/* name of registry (for registry operations) */
dcl	bl		   fixed bin (21);
dcl	error_code	   fixed bin (35);
dcl	local_code	   fixed bin (35);

dcl	bp		   ptr;
dcl	operation_ptr	   ptr;

dcl	1 en_access_op	   like encoded_access_op aligned based (operation_ptr);

dcl	addr		   builtin;
dcl	bin		   builtin;
dcl	null		   builtin;
dcl	rtrim		   builtin;
dcl	size		   builtin;
dcl	unspec		   builtin;

/*            EXTERNAL                       */

dcl	access_audit_r1_$check_obj_class_range
			   entry (bit (36) aligned, bit (36) aligned, (2) bit (72) aligned) returns (bit (1));
dcl	access_audit_r1_$log_obj_class_range
			   entry options (variable);
dcl	hcs_$get_access_class  entry (char (*), char (*), bit (72) aligned, fixed bin (35));
dcl	ioa_$rsnnl	   entry () options (variable);
dcl	pathname_		   entry (char (*), char (*)) returns (char (168));
dcl	rcp_setup_event	   entry (bit (36) aligned, bit (3), bit (36) aligned, fixed bin (35));
dcl	resource_info_$get_type
			   entry (char (*), bit (1), fixed bin (35));
dcl	suffixed_name_$make	   entry (char (*), char (*), char (32), fixed bin (35));

dcl	access_operations_$rcp_set
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_set_access
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_delete_registry
			   bit (36) aligned external;
dcl	access_operations_$rcp_copy_registry
			   bit (36) aligned external;
dcl	access_operations_$rcp_update_registry_header
			   bit (36) aligned external;
dcl	access_operations_$rcp_reconstruct_registry
			   bit (36) aligned external;

/*	CONSTANTS		*/

dcl	COMPONENT_0_NAME	   char (1) static options (constant) init ("0");
dcl	REGISTRY_SUFFIX	   char (4) static options (constant) init ("rcpr");
dcl	REGISTRY_OLD_SUFFIX	   char (3) static options (constant) init ("old");

/*  Copy argument data */

	caller = a_caller;
	operation = a_operation;
	base_op = operation;
	addr (base_op) -> en_access_op.detailed_operation = 0;
	ops_ptr = addr (addr (operation) -> en_access_op.detailed_operation);
	requestor_info_ptr = a_req_info_ptr;
	resource_info_ptr = a_res_info_ptr;
	owner = a_owner;
	effmode = a_effmode;
	raw_mode = a_raw_mode;
	rbs = a_rbs;
	rm_on = a_rm_on;
	error_code = a_error_code;

/*  Initialize local variables. */

	audit = "0"b;
	event_flags = "0"b;
	object_name = "";
	local_code = 0;
	bp = null ();
	bl = 0;

/*  If resource management is not enabled then don't audit.  If this is */
/*  a search operation then we don't audit either. */
/*  If it's a reconstruct operation we are in the Initializer process and */
/*  rm is not turned on, since reconstructs are done in "stan". */

	if (^rm_on & (base_op ^= access_operations_$rcp_reconstruct_registry)) | detailed_operation.search then
	     goto MAIN_RETURN;

/*  Set up the RCP event.  We already have the oper_code in base_op. */

	call rcp_setup_event (operation, effmode, event_flags, local_code);
	if local_code ^= 0 then
	     goto MAIN_RETURN;

/*  Get the access class range of the object. */

	registry_dir = resource_info.registry_dir;
	if registry_operation (base_op) then do;	/* the registry itself is the object */
	     if base_op = access_operations_$rcp_delete_registry then
		call suffixed_name_$make (resource_info.resource_type, REGISTRY_OLD_SUFFIX, registry_name, local_code)
		     ;
	     else call suffixed_name_$make (resource_info.resource_type, REGISTRY_SUFFIX, registry_name, local_code);
	     if local_code ^= 0 then
		goto MAIN_RETURN;
/**** Low end of access class range is access class of the directory (registry), high end is that of component 0. ****/
	     call hcs_$get_access_class (registry_dir, registry_name, object_access_class (1), local_code);
	     if local_code ^= 0 then
		goto MAIN_RETURN;
	     call hcs_$get_access_class (pathname_ (registry_dir, registry_name), COMPONENT_0_NAME,
		object_access_class (2), local_code);
	     if local_code ^= 0 then
		goto MAIN_RETURN;
	end;
	else do;					/* we can use the registry to find out the access class range */
	     record_ptr = resource_info.registry_record_ptr;
	     if registry_record.free then
		call chase (registry_record.potential_aim_range_desc, bp, bl, local_code);
	     else call chase (registry_record.aim_range_desc, bp, bl, local_code);
	     if local_code ^= 0 then
		goto MAIN_RETURN;
	     if bl > 0 then addr (object_access_class) -> based_bits = based_bits;
	     else unspec (object_access_class) = ""b;	/* no range, set to lowest possible */
	end;

/*  Determine if access is needed. */

	audit = access_audit_r1_$check_obj_class_range (event_flags, base_op, object_access_class);

/*  If auditing is required then do it. */

	if audit then do;
	     call get_obj_name ();
	     audit_rcp_obj_ptr = addr (auto_rcp_obj_info);
	     call fill_audit_record (local_code);
	     if local_code ^= 0 then
		goto MAIN_RETURN;
	     call get_msg_str ();
	     call access_audit_r1_$log_obj_class_range (caller, (requestor_info.validation_level), event_flags, base_op,
		object_access_class, rtrim (object_name), error_code, addr (rcp_obj_info), (size (rcp_obj_info)),
		msg_str);
	end;

MAIN_RETURN:
	return;
%page;
chase:
     proc (descriptor, bp, bl, a_error_code);

dcl	(
	descriptor	   fixed bin (35),
	a_error_code	   fixed bin (35),
	bp		   pointer,
	bl		   fixed bin (21)
	)		   parameter;

dcl	1 rs		   like rs_info aligned automatic;
dcl	local_code	   fixed bin (35);
dcl	error_table_$action_not_performed
			   ext static fixed bin (35);

	a_error_code = 0;
	if descriptor = 0 then do;
	     bp = addr (bp);			/* gotta point somewhere */
	     bl = 0;
	     return;
	end;

	unspec (rs) = ""b;
	rs.version = rs_info_version_2;
	rs.locate_sw = "1"b;
	rs.descriptor = descriptor;
	local_code = 0;

	call iox_$control (resource_info.registry_switch_ptr, "record_status", addr (rs), local_code);
	if local_code ^= 0 then do;
	     a_error_code = error_table_$action_not_performed;
	     return;
	end;
	bl = rs.record_length;
	bp = rs.record_ptr;

	return;
%include rs_info;
%include iox_dcls;
     end chase;

get_obj_name:
     proc ();

	if registry_operation (base_op) then
	     object_name = "Registry " || pathname_ (registry_dir, resource_info.resource_type);

	else object_name = (rtrim (resource_info.resource_type)) || " " || resource_info.resource_name;

	return;

     end get_obj_name;

registry_operation:
     proc (op) returns (bit (1) aligned);

dcl	op		   bit (36) aligned;

	return (op = access_operations_$rcp_copy_registry | op = access_operations_$rcp_delete_registry
	     | op = access_operations_$rcp_reconstruct_registry | op = access_operations_$rcp_update_registry_header);

     end registry_operation;

fill_audit_record:
     proc (a_code);

dcl	a_code		   fixed bin (35);

dcl	is_vol		   bit (1);
dcl	fill_code		   fixed bin (35);

	fill_code = 0;
	is_vol = "0"b;
	unspec (rcp_obj_info) = ""b;
	rcp_obj_info.info_type = AAB_rcp_object;
	rcp_obj_info.version = AUDIT_RCP_OBJ_INFO_VERSION_1;
	rcp_obj_info.pad = "0"b;
	rcp_obj_info.resource_type = resource_info.resource_type;
	rcp_obj_info.resource_name = resource_info.resource_name;
	rcp_obj_info.owner_id = owner;
	rcp_obj_info.access_class = object_access_class;
	rcp_obj_info.raw_mode = raw_mode;
	rcp_obj_info.rcp_ring_brackets = rbs;
	if registry_operation (base_op) then
	     rcp_obj_info.registry = "1"b;
	else do;
	     call resource_info_$get_type (resource_info.resource_type, is_vol, fill_code);
	     if fill_code ^= 0 then
		goto FILL_RETURN;
	     rcp_obj_info.device = ^is_vol;
	     rcp_obj_info.volume = is_vol;
	     rcp_obj_info.usage_locked = registry_record.usage_lock;
	     rcp_obj_info.release_locked = registry_record.release_lock;
	     rcp_obj_info.awaiting_clear = registry_record.awaiting_clear;
	     rcp_obj_info.has_acs_path = (registry_record.acs_path_desc ^= 0);
	     rcp_obj_info.flags.pad = "0"b;
	     rcp_obj_info.attributes = registry_record.attributes;
	end;

FILL_RETURN:
	a_code = fill_code;
	return;
     end fill_audit_record;

get_msg_str:
     proc ();

	call ioa_$rsnnl (
	     "^[raw_mode=^a ^;^s^]^[rcp_ring_brackets=^d,^d ^;^2s^]^[^[potential_attributes ^]^[desired_attributes ^]^[potential_aim_range ^]^[aim_range ^]^[owner ^]^[acs_path ^]^[location ^]^[comment ^]^[charge_type ^]^[usage_lock ^]^[release_lock ^]^[user_alloc^]^]",
	     msg_str, (0), (raw_mode ^= ""b), SEG_ACCESS_MODE_NAMES (bin (rcp_obj_info.raw_mode)), (rbs (1) ^= -1),
	     rcp_obj_info.rcp_ring_brackets,
	     (base_op = access_operations_$rcp_set | base_op = access_operations_$rcp_set_access),
	     detailed_operation.given.potential_attributes, detailed_operation.given.desired_attributes,
	     detailed_operation.given.potential_aim_range, detailed_operation.given.aim_range,
	     detailed_operation.given.owner, detailed_operation.given.acs_path, detailed_operation.given.location,
	     detailed_operation.given.comment, detailed_operation.given.charge_type,
	     detailed_operation.given.usage_lock, detailed_operation.given.release_lock,
	     detailed_operation.given.user_alloc);

     end get_msg_str;

%include access_audit_binary_def;
%page;
%include access_audit_encoded_op;
%page;
%include access_audit_rcp_info;
%page;
%include access_mode_values;
%page;
%include rcp_ops;
%page;
%include rcp_requestor_info;
%page;
%include rcp_resource_info;
%page;
%include rcp_registry;
     end rcp_audit;




		    rcp_authenticate_device_.pl1    11/11/89  1110.3rew 11/11/89  0806.7       59517



/****^  ***********************************************************
        *                                                         *
        * 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-01-15,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-14,Farley), install(86-07-17,MR12.0-1097):
     Add support for subvolumes by setting a priority for authentication.
                                                   END HISTORY COMMENTS */


rcp_authenticate_device_: proc (a_device_name, a_oper_auth_code, a_code);

/*  This  program  takes  a  device name and an authentication code.  For tape
   drives   it  gets  the  user  specified  volume  name,  converts  it  with
   authenticate_  and checks it against the operator specified authentication
   code  ("***",  if permitted, matches any code).  For disk drives it checks
   the authentication code against the disk label type flags in the rcse.
*/
/*
   Written by R.J.C. Kissel in September 1977.
   Modified by R.J.C. Kissel 1/79 to handle disk authentication.
   Modified 05/79 by C. D. Tavares to handle new authentication levels.
   Modified 6/79 by Michael R. Jordan for MR7.0R.
*/

dcl  a_device_name char (*);
dcl  a_oper_auth_code char (*);
dcl  a_code fixed bin (35);

dcl  UPPER char (26) static internal options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  LOWER char (26) static internal options (constant) init ("abcdefghijklmnopqrstuvwxyz");

dcl  device_name char (32);
dcl  oper_auth_code char (3);
dcl  code fixed bin (35);

dcl  user_label char (32);
dcl  caller_level fixed bin;
dcl  found bit (1);
dcl  i fixed bin;

dcl  authenticate_ entry (char (*)) returns (char (3) aligned);
						/* In upper case. */
dcl  rcp_pointers_$com_seg entry () returns (ptr);
dcl  rcp_pointers_$data entry () returns (ptr);
dcl  hcs_$wakeup entry (bit (36), fixed bin (71), fixed bin (71), fixed bin (35));
dcl  get_ring_ entry () returns (fixed bin);
dcl  cu_$level_get entry (fixed bin);
dcl  cu_$level_set entry (fixed bin);
dcl  rcp_lock_$lock entry (ptr, fixed bin (35));
dcl  rcp_lock_$unlock entry (ptr);

dcl (error_table_$auth_incorrect,
     error_table_$auth_unknown,
     error_table_$dev_nt_assnd,
     error_table_$action_not_performed,
     error_table_$improper_data_format) external fixed bin (35);

dcl  cleanup condition;

dcl (translate, addr, substr, null) builtin;

	code = 0;
	lock_info_ptr = null ();

	call cu_$level_get (caller_level);

	on cleanup
	     call CLEANUP;

	call cu_$level_set (get_ring_ ());

	device_name = a_device_name;
	oper_auth_code = a_oper_auth_code;

	rcpd_ptr = rcp_pointers_$data ();
	rcs_ptr = rcp_pointers_$com_seg ();

	lock_info_ptr = addr (rcs.lock_info);
	call rcp_lock_$lock (lock_info_ptr, code);

	if code ^= 0
	then do;
	     call CLEANUP;
	     return;
	end;

	found = "0"b;

	do i = 1 to rcs.num_entries by 1 while (^found);
	     rcse_ptr = addr (rcs.entry (i));

	     if rcse.device_name = device_name /* Right device. */ & rcse.kind = 1 /* The attach entry. */ & rcse.state ^= 0
						/* Not free, i.e. probably attaching. */
	     then found = "1"b;
	end;

	if ^found
	then do;
	     code = error_table_$dev_nt_assnd;
	     call CLEANUP;
	     return;
	end;

	if ^rcse.flags.need_auth | (substr (device_name, 1, 3) ^= "tap" & substr (device_name, 1, 3) ^= "dsk")
	then do;
	     code = error_table_$action_not_performed;
	     call CLEANUP;
	     return;
	end;

	if substr (device_name, 1, 3) = "tap" then do;	/* Handle tape authentication. */

	     if rcpd.modes.authentication_level = No_authentication then
		goto auth_ok;

	     if rcpd.modes.authentication_level = Nominal_authentication then
		if oper_auth_code = "***" then goto auth_ok;

/* full auto or manual authentication */

	     if oper_auth_code = "***" then do;		/* don't allow this */
		code = error_table_$improper_data_format;
		call CLEANUP;
		return;
	     end;

	     user_label = rcse.volume_name;

	     if (translate (oper_auth_code, UPPER, LOWER) = authenticate_ (user_label)) then
auth_ok:		do;
		rcse.have_auth = "1"b;
		rcse.auth_set = "1"b;
		rcse.need_auth = "0"b;
	     end;

	     else do;
		rcse.have_auth = "0"b;
		rcse.auth_set = "1"b;
		rcse.need_auth = "0"b;
	     end;

	     call hcs_$wakeup ((rcse.process_id), rcse.event_id, 0, code);

	     call CLEANUP;
	     return;
	end;					/* Handle tape authentication. */

	else do;					/* Handle disk authentication. */
	     if oper_auth_code = "no"
	     then do;				/* Operator has denied authentication. */
		rcse.have_auth = "0"b;
		rcse.auth_set = "1"b;
		rcse.need_auth = "0"b;
	     end;				/* Operator has denied authentication. */

	     else if (oper_auth_code = "ss") | (oper_auth_code = "io") | (oper_auth_code = "urd") | (oper_auth_code = "urg")
	     then do;
		if (rcse.flags.disk_ss_pack | rcse.flags.disk_copy_of_ss_pack) & ^(oper_auth_code = "ss")
                    then goto wrong_auth_code;
		else if (rcse.flags.disk_io_pack & ^(oper_auth_code = "io"))
		then goto wrong_auth_code;
		else if (rcse.flags.disk_unreadable & ^(oper_auth_code = "urd"))
		then goto wrong_auth_code;
		else if (rcse.flags.disk_unregistered & ^(oper_auth_code = "urg"))
		then goto wrong_auth_code;
						/* Operator has authenticated the pack. */
	          rcse.have_auth = "1"b;
		rcse.auth_set = "1"b;
		rcse.need_auth = "0"b;
	     end;				          /* Operator has authenticated the pack. */
               else do;				/* Unknown authentication code. */
		code = error_table_$auth_unknown;
		call CLEANUP;
		return;
	     end;

	     call hcs_$wakeup ((rcse.process_id), rcse.event_id, 0, code);
						/* Inform user the operator is done. */

	     call CLEANUP;
	     return;
	end;					/* Handle disk authentication. */
wrong_auth_code:
       code = error_table_$auth_incorrect;
       call CLEANUP;
       return;
						/*  */
CLEANUP:
	proc;

	     if lock_info_ptr ^= null
	     then call rcp_lock_$unlock (lock_info_ptr);

	     call cu_$level_set (caller_level);
	     a_code = code;

	end CLEANUP;

%include rcp_data;

%include rcp_com_seg;


     end rcp_authenticate_device_;




		    rcp_auto_register_.pl1          11/11/89  1110.3r   11/11/89  0806.9       31437



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


rcp_auto_register_: proc (rsct, resource_name, group_id, code);


/*

   This procedure will register the specified resource for the specified user.  It is called
   when a volume must be automatically registered for a user.

   Initially coded 3/79 by Michael R. Jordan for MR7.0R

*/

/*		PARAMETERS		*/


dcl  code fixed bin (35);				/* Error code. */
dcl  group_id char (*);				/* Nmae of the user. */
dcl  resource_name char (*);				/* Name of the resource to be registered. */
dcl  rsct char (*);					/* Type of resource to register. */


/*		ENTRIES CALLED		*/


dcl  admin_gate_$syserr entry options (variable);
dcl  rcp_pointers_$com_seg entry () returns (ptr);
dcl  rcprm_find_resource_$auto_register entry (ptr, char (*), fixed bin (35));
dcl  resource_info_$defaults entry (char (*), char (*), ptr, fixed bin, fixed bin (35));


/*		ERROR CODES		*/


dcl  error_table_$action_not_performed fixed bin (35) ext;
dcl  error_table_$rcp_no_auto_reg fixed bin (35) ext;


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  size builtin;
dcl  string builtin;

%include rcp_com_seg;

%include resource_control_desc;

	code = 0;					/* No error, yet. */
	Resource_count = 1 ;			/* Just one resource to register. */

	begin;
dcl  garbage (size (resource_descriptions)) bit (36);

	     string (garbage) = "0"b;
	     resource_desc_ptr = addr (garbage);
	     resource_descriptions.version_no = resource_desc_version_1;
	     resource_descriptions.n_items = 1;
	     call resource_info_$defaults (rsct, "", resource_desc_ptr, 0, code);
	     if code ^= 0 then return;
	     if ^resource_descriptions.item (1).given.potential_attributes
	     | ^resource_descriptions.item (1).given.potential_aim_range
	     | ^resource_descriptions.item (1).given.charge_type
	     then do;
		code = error_table_$rcp_no_auto_reg;
		return;
	     end;
	     resource_descriptions.item (1).name = resource_name;
	     resource_descriptions.item (1).given.name = "1"b;
	     resource_descriptions.item (1).owner = group_id;
	     resource_descriptions.item (1).given.owner = "1"b;
	     call rcprm_find_resource_$auto_register (resource_desc_ptr, (rcp_pointers_$com_seg () -> rcs.acs_directory), code);
	     if code = error_table_$action_not_performed
	     then code = resource_descriptions.item (1).status_code;
	end;

	if code = 0
	then call admin_gate_$syserr (0, "RCP: ^a ^a registered and acquired to ^a.",
	     rsct, resource_name, group_id);

	return;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: RESOURCE_TYPE RESOURCE_NAME registered and acquired to USER.

   S:	$info

   T:	$run

   M:	The resource RESOURCE_NAME has been automatically registered and acquired to
   USER.  It is a resource of the type RESCOURCE_TYPE.

   A:	$ignore


   END MESSAGE DOCUMENTATION */


     end rcp_auto_register_;




		    rcp_cancel_id_.pl1              11/11/89  1110.3rew 11/11/89  0805.2       97497



/****^  ***********************************************************
        *                                                         *
        * 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-25,Rauschelbach), approve(87-06-29,MCR7736),
     audit(87-07-21,Farley), install(87-08-06,MR12.1-1063):
     System error message documentation was added.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_cancel_id_:
     proc (a_reservation_id, a_group_id, a_code);

/*
   *       This subroutine will implement the privileged reservation cancelling
   *  function needed by the operator and initializer process.  It uses
   *  the reservation_id to cancel the reservations of all the resources
   *  associated with that id.  The group_id is used to help guarantee
   *  that the reservation_id was correctly entered, it must match the
   *  reserved_for field of the reservation.
   *       This subroutine will be used by the absentee manager when
   *  terminating a process for which a reservation was made; and also
   *  by the operator, if some terrible calamity befalls the initializer
   *  process, to clean up leftover reservations.
*/

/*
   Written by R.J.C. Kissel 5/78.
   Modified by R.J.C. Kissel 1/79 to handle rcp_ gate calls and ambiguous request ids.
   Modified by Chris Jones 1/85 to stop using magic numbers.
*/

/* Arguments */

dcl  a_reservation_id fixed bin (71);
dcl  a_group_id char (*);
dcl  a_code fixed bin (35);

/* Local Variables */

dcl  string bit (1);
dcl  system bit (1);

dcl  rstr_id char (19);
dcl  prc_id bit (36);
dcl  res_id fixed bin (71);
dcl  log_res_id char (19);
dcl  grp_id char (32) aligned;
dcl  code fixed bin (35);
dcl  i fixed bin;					/* Index in rcpd. */
dcl  any_found bit (1);

dcl  caller_level fixed bin;

/* Local Constants */

/* Local Overlays */

/* External Entries */

dcl  cu_$level_get entry (fixed bin);
dcl  cu_$level_set entry (fixed bin);
dcl  get_ring_ entry returns (fixed bin);
dcl  rcp_cancel_resource_
     entry (char (*), char (*), fixed bin (35));
dcl  rcp_pointers_$data entry returns (ptr);
dcl  rcp_pointers_$com_seg
     entry returns (ptr);
dcl  rcp_lock_$lock entry (ptr, fixed bin (35));
dcl  rcp_lock_$unlock entry (ptr);
dcl  rcp_match_user_name_
     entry (char (32) aligned, char (32) aligned) returns (bit (1));
dcl  request_id_ entry (fixed bin (71)) returns (char (19));
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  admin_gate_$syserr entry options (variable);
dcl  get_process_id_ entry () returns (bit (36));
dcl  match_request_id_ entry (fixed bin (71), char (*)) returns (bit (1) aligned);

/* External Constants */

dcl  error_table_$noentry
     fixed bin (35) external;
dcl  error_table_$badcall
     fixed bin (35) external;
dcl  error_table_$request_id_ambiguous
     fixed bin (35) external;
dcl  error_table_$invalid_resource_state
     fixed bin (35) external;

/* Builtin Functions and Conditions */

dcl (addr, clock, rel, unspec)
     builtin;
dcl (cleanup) condition;

	string = "0"b;
	system = "0"b;
	goto START;
	
string:
	entry (a_res_id, a_code);

dcl  a_res_id char (*);

	string = "1"b;
	system = "0"b;
	goto START;
	
sys:
	entry (a_reservation_id, a_group_id, a_code);

	string = "0"b;
	system = "1"b;
	goto START;
	
sys_string:
	entry (a_res_id, a_group_id, a_code);

	string = "1"b;
	system = "1"b;
	goto START;

START:
	if string
	then rstr_id = a_res_id;
	else res_id = a_reservation_id;

	if system
	then grp_id = a_group_id;
	else prc_id = get_process_id_ ();

	call cu_$level_get (caller_level);

	on cleanup
	     call cleanup_handler;

	call cu_$level_set (get_ring_ ());

	rcpd_ptr = rcp_pointers_$data ();
	rcs_ptr = rcp_pointers_$com_seg ();

	call rcp_lock_$lock (addr (rcpd.lock_info), code);

	if code ^= 0
	then goto BAD_ERROR;

/*
   *       Loop through the rcp data base looking for the reservation
   *  id.  Then cancel the reservation.
*/

	any_found = "0"b;

	if string
	then do;					/* Check for ambiguous res id, and state not reserved. */
	     res_id = 0b;

	     do i = 1 to rcpd.tot_devices;
		if match_request_id_ (rcpd.device (i).reservation_id, rstr_id)
		then do;				/* Only check ones that match. */
		     any_found = "1"b;

		     if rcpd.device (i).state ^= RESERVED
						/* Not reserved. */
		     then code = error_table_$invalid_resource_state;

		     if res_id = 0b
		     then res_id = rcpd.device (i).reservation_id;

		     else if res_id ^= rcpd.device (i).reservation_id
		     then goto BAD_RID;

		     else ;
		end;				/* Only check ones that match. */
	     end;

	     do i = 1 to rcpd.last_volume;
		if match_request_id_ (rcpd.volume (i).reservation_id, rstr_id)
		then do;				/* Only check ones that match. */
		     any_found = "1"b;

		     if rcpd.volume (i).state ^= RESERVED
						/* Not reserved. */
		     then code = error_table_$invalid_resource_state;

		     if res_id = 0b
		     then res_id = rcpd.volume (i).reservation_id;

		     else if res_id ^= rcpd.volume (i).reservation_id
		     then goto BAD_RID;

		     else ;
		end;				/* Only check ones that match. */
	     end;

	     if ^any_found
	     then goto NONE_FOUND;

	     if code ^= 0
	     then goto ALREADY_ASSND;

	     any_found = "0"b;
	end;					/* Check for ambiguous res id, and state not reserved. */

	log_res_id = request_id_ (res_id);

	do i = 1 to rcpd.tot_devices;
	     if rcpd.device (i).reservation_id = res_id
	     then do;

		if system
		then do;
		     if ^rcp_match_user_name_ (rcpd.device (i).group_id, grp_id)
		     then goto BAD_GROUP;
		end;

		else do;
		     if rcpd.device (i).process_id ^= prc_id
		     then goto BAD_PRC;
		end;
              
		any_found = "1"b;
		device_ptr = addr (rcpd.device (i));

		call rcp_cancel_resource_ (DEVICE_TYPE (device.dtypex), (device.device_name), code);
                    if code ^= 0 then
                       goto BAD_ERROR;

		call admin_gate_$syserr (JUST_LOG, "RCP: Cancelled device ^a for ^a (id=^a)", device.device_name,
		     device.group_id, log_res_id);

		call ACCOUNT_WAKEUP (device_ptr, RCP_ACCTMSG_unassign);

		if device.volume_name = ""
		then device.group_id = "";		/* Only if not preloaded. */

		device.reservation_id = 0;
		device.reserved_by = "";
		device.process_id = "0"b;
		device.state_time = clock ();
		device.state = FREE;		/* Free. */
	     end;
	end;

	do i = 1 to rcpd.last_volume;
	     if rcpd.volume (i).reservation_id = res_id
	     then do;

		if system
		then do;
		     if ^rcp_match_user_name_ (rcpd.volume (i).group_id, grp_id)
		     then goto BAD_GROUP;
		end;

		else do;
		     if rcpd.volume (i).process_id ^= prc_id
		     then goto BAD_PRC;
		end;

		any_found = "1"b;
		volume_ptr = addr (rcpd.volume (i));

		call admin_gate_$syserr (JUST_LOG, "RCP: Cancelled volume ^a for ^a (id=^a)", volume.volume_name,
		     volume.group_id, log_res_id);

		call rcp_cancel_resource_ (VOLUME_TYPE (volume.vtypex), (volume.volume_name), code);
						/* Ignore the code. */

		volume.group_id = "";
		volume.reservation_id = 0;
		volume.reserved_by = "";
		volume.process_id = "0"b;
		volume.state_time = clock ();
		volume.state = FREE;		/* Free. */
	     end;
	end;

	if ^any_found
	then goto NONE_FOUND;

	a_code = 0b;
	call rcp_lock_$unlock (addr (rcpd.lock_info));
	call cu_$level_set (caller_level);
	return;

remove_schedule:
	entry (a_resource_desc_ptr, resource_no, registry_dir, reserver_info_ptr, reserver_chain, a_code);

/* This entry is called by rcprm_find_resource_$cancel to finish the cancellation of a resource once it
   has made sure that the cancellation may be requested by the caller (access control function.) */
/* Right now it is a no-op-- in fact, I would be surprised if anyone ever called rcprm_find_resource_$cancel. */

dcl (
     a_resource_desc_ptr pointer,
     resource_no fixed bin,
     registry_dir char (*),
     reserver_info_ptr pointer,
     reserver_chain bit (18) unaligned
     ) parameter;

	a_code = 0;				/* I'm OK, you're OK */
	return;

BAD_ERROR:
	call cleanup_handler;
	a_code = code;
	return;

BAD_GROUP:
	call cleanup_handler;
	a_code = error_table_$badcall;
	return;

BAD_PRC:
	call cleanup_handler;
	a_code = error_table_$badcall;
	return;

BAD_RID:
	call cleanup_handler;
	a_code = error_table_$request_id_ambiguous;
	return;

NONE_FOUND:
	call cleanup_handler;
	a_code = error_table_$noentry;
	return;

ALREADY_ASSND:
	call cleanup_handler ();
	a_code = code;
	return;

ACCOUNT_WAKEUP:
	procedure (a_devptr, a_action);

/*	This procedure is called to format an accounting message, and send it to the
   *	accounting process.  If the accounting event channel has not been set up, no message is sent.
*/


dcl  a_devptr ptr;					/* Pointer to rcp_data entry */
dcl  a_action fixed bin;				/* Accounting action */

dcl  wakeup_buf fixed bin (71);
dcl 1 auto_rcpamsg like rcp_account_msg aligned;

	     unspec (auto_rcpamsg) = "0"b;

	     auto_rcpamsg.device_user_procid = a_devptr -> device.process_id;
	     auto_rcpamsg.rcp_data_relp = rel (a_devptr);
	     auto_rcpamsg.devtype = a_devptr -> device.dtypex;
	     auto_rcpamsg.action = a_action;

	     unspec (wakeup_buf) = unspec (auto_rcpamsg);
	     if rcpd.accounting_chan ^= 0
	     then call hcs_$wakeup (rcpd.accounting_pid, rcpd.accounting_chan, wakeup_buf, (0));

	end ACCOUNT_WAKEUP;

cleanup_handler:
	proc;

	     call rcp_lock_$unlock (addr (rcpd.lock_info));
	     call cu_$level_set (caller_level);

	end cleanup_handler;

/* Include Files */

%include rcp_data;
%page;
%include rcp_com_seg;
%page;
%include rcp_account_msg;
%page;
%include rcp_resource_types;
%page;
%include rcp_resource_states;
%page;
%include syserr_constants;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Cancelled device devX_MM for GRP_ID (id=RES_ID)

   S:	$log

   T:	$run

   M:	A device reservation has been cancelled by the operator, the
	absentee manager or the Initializer.

   A:	$ignore


   Message:
   RCP: Cancelled volume volume_name for GRP_ID (id=RES_ID)

   S:	$log

   T:	$run

   M:	A volume reservation has been cancelled by the operator, the
	absentee manager or the Initializer.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end rcp_cancel_id_;




		    rcp_cancel_resource_.pl1        11/11/89  1110.3r   11/11/89  0806.9       24534



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


rcp_cancel_resource_: proc (rsc_type, rsc_name, code);


/*

   This procedure will tell Resource Management when RCP is finished with a resource.  It will only
   do so if Resource Management is enabled.


   Initially coded 3/79 by Michael R. Jordan for MR7.0R.


*/

/*		PARAMETERS		*/


dcl  code fixed bin (35);				/* Error code. */
dcl  rsc_name char (*);				/* Name of the resource. */
dcl  rsc_type char (*);				/* Type of resource. */


/*		ERROR CODES		*/


dcl  error_table_$action_not_performed fixed bin (35) ext;


/*		ENTRIES CALLED		*/


dcl  rcp_pointers_$com_seg entry () returns (ptr);
dcl  rcp_pointers_$data entry () returns (ptr);
dcl  rcprm_find_resource_$cancel entry (ptr, char (*), ptr, fixed bin (35));


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  null builtin;
dcl  size builtin;
dcl  string builtin;

%include rcp_data;

%include rcp_com_seg;

%include resource_control_desc;

/*

   Get everything set and check to see if Resource Management is enabled.

*/


	code = 0;					/* No error. */

	rcpd_ptr = rcp_pointers_$data ();
	rcs_ptr = rcp_pointers_$com_seg ();

	if ^rcpd.modes.resource_mgmt_enabled		/* No Resource Management, no work. */
	then return;


/*

   Now that we know Resource Management is enabled, we can tell him that we are
   finished with this resource.

*/


	Resource_count = 1;				/* Only one resource. */

	begin;

dcl  garbage (size (resource_descriptions)) bit (36);


	     string (garbage) = ""b;
	     resource_desc_ptr = addr (garbage);

	     resource_descriptions.version_no = resource_desc_version_1;
	     resource_descriptions.n_items = 1;
	     resource_descriptions.item (1).type = rsc_type;
	     resource_descriptions.item (1).name = rsc_name;
	     resource_descriptions.item (1).given.name = "1"b;

	     call rcprm_find_resource_$cancel (resource_desc_ptr, (rcs.acs_directory), null (), code);

	     if code = error_table_$action_not_performed then
		code = resource_descriptions.item (1).status_code;

	end;


	return;


     end rcp_cancel_resource_;




		    rcp_check_assign_.pl1           11/11/89  1110.3r   11/11/89  0805.9       44892



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_check_assign_:
     procedure (arg_rcp_id, arg_device_info_ptr, arg_comment, arg_statex, arg_ecode);

/*	This program implements the rcp_$check_assign entry point.
   *	Created on 12/04/74 by Bill Silver.
   *
   *	The rcp_id is used to generate a pointer to the RCS entry that is associated
   *	with this assignment request.  We will look in this RCS entry to obtain
   *	the information that describes the results of the assignment operation.
   *	In the current implementation the assignment is actually performed by the
   *	assign call.  If everything in the RCS entry is OK we will declare the
   *	assignment to be completed and will return the device information to
   *	the caller.
*/

/*		ARGUMENT  DATA		*/

dcl	arg_comment	   char (*);		/* (O) RCP comment. */
dcl	arg_device_info_ptr	   ptr;			/* (I) Pointer to device info structure. */
dcl	arg_ecode		   fixed bin (35);		/* (O) Return error_table_ code. */
dcl	arg_rcp_id	   bit (36) aligned;	/* (I) RCP ID. */
dcl	arg_statex	   fixed bin;		/* (O) State of assignment check. */


/*		AUTOMATIC  DATA		*/

dcl	caller_level	   fixed bin;		/* Caller's validation level. */
dcl	dcode		   fixed bin (35);		/* Dummy error code. */
dcl	ecode		   fixed bin (35);		/* error_table_ code. */
dcl	rcp_id		   bit (36) aligned;	/* Used to copy rcp_id argument. */
dcl	save_ecode	   fixed bin (35);		/* Dummy error code. */


/*		EXTERNAL ENTRIES CALLED	*/

dcl	cleanup		   condition;		/* Used to set up a cleanup handler. */

dcl	(
	error_table_$bad_arg,
	error_table_$invalid_state,
	error_table_$out_of_sequence
	)		   fixed bin (35) external;

dcl	clock_		   entry returns (fixed bin (71));
dcl	cu_$level_get	   entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	get_ring_		   entry returns (fixed bin);
dcl	rcp_comment_	   entry (ptr);
dcl	rcp_device_info_$set   entry (ptr, ptr, fixed bin (35));
dcl	rcp_unassign_$unassign entry (bit (36) aligned, bit (*), char (*), fixed bin (35));
dcl	rcp_validate_	   entry (bit (36) aligned, fixed bin, ptr, fixed bin (35));

	call cu_$level_get (caller_level);		/* Save caller's validation level. */
	on cleanup
	     begin;				/* If trouble cleanup. */
	     call cu_$level_set (caller_level);		/* Reset validation level. */
	end;
	call cu_$level_set (get_ring_ ());		/* Set validation level to RCP level. */

	rcp_id = arg_rcp_id;			/* Copy arguments. */
	device_info_ptr = arg_device_info_ptr;
	call rcp_validate_ (rcp_id, caller_level, rcse_ptr, ecode);
	if ecode ^= 0				/* Is RCP ID OK? */
	     then
	     goto ERROR;				/* No, rcse_ptr is not valid. */

	if rcse.kind ^= 2				/* Is this a device assignment RCS entry? */
	then do;					/* No, leave attachment alone. */
	     ecode = error_table_$bad_arg;
	     goto ERROR;
	end;

	ecode = rcse.ecode;				/* Get code generated by rcp_initializer_. */
	if ecode ^= 0				/* Was there an error assigning the device? */
	     then
	     goto ERROR;

	if rcse.state ^= 2				/* We should be in the ASSIGNED state. */
	then do;					/* But we are not. */
	     ecode = error_table_$invalid_state;
	     goto ERROR;
	end;

/*	Return the information about the assigned device in the info structure.
*/
/**** Passing a copy of device_info_ptr is OK since the pointer is used to base
      a write-only structure, so nothing the caller is doing can throw us. ****/
	call rcp_device_info_$set (device_info_ptr, rcse_ptr, ecode);
	if ecode ^= 0				/* Is device info structure valid? */
	     then
	     goto ERROR;				/* Abort assignment. */

	call rcp_comment_ (rcse_ptr);			/* Type caller's comment. */

	rcse.state = 5;				/* Assignment now complete. */
	rcse.state_time = clock_ ();

	arg_comment = "";				/* No comments returned by this version of RCP. */
	arg_statex,				/* Tell caller that assignment completed OK. */
	     arg_ecode = 0;
	call cu_$level_set (caller_level);		/* Reset caller's validation level. */
	return;

ERROR:						/* Abort assignment. */
	call rcp_unassign_$unassign (rcp_id, "0"b, "", dcode);
	arg_statex = 3;				/* Tell caller there was an error. */
	arg_ecode = ecode;				/* Return error code. */
	call cu_$level_set (caller_level);		/* Reset validation level. */

%include rcp_com_seg;
%page;
%include rcp_device_info_structs;

     end rcp_check_assign_;




		    rcp_check_attach_.pl1           11/11/89  1110.3rew 11/11/89  0805.2      138744



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

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */

rcp_check_attach_:
     procedure (arg_rcp_id, arg_device_info_ptr, arg_comment, arg_ioi_index, arg_workspace_max, arg_timeout_max,
	arg_statex, arg_ecode);

/*	This program implements the rcp_$check_attach entry point.
   *	Created on 12/04/74 by Bill Silver.
   *	Accounting by B. Greenberg, 8/2/77.
   *	Modified on 09/19/77 by R.J.C. Kissel to check workspace.acs for big workspace access.
   *	Modified on 04/28/78 by Michael R. Jordan to allow preloaded volumes.
   *	Modified on 02/08/79 by Michael R. Jordan for MSS0500 support.
   *	Modified on 05/03/82 by E. N. Kittlitz to set ioi_timeout if UR device.
   *	Modified on 01/24/83 by J. A. Bush to copy the label type and density into the asignment rcse
   *	Modified 830818 to replace take_console call with console_free call... -E. A. Ranzenbach
   *      Modified 841009 to interface with rcp_control_ instead of rcp_initializer_... - M. M. Pozzo
   *      Modified 850131 general cleanup...M. M. Pozzo
*/

/****^  HISTORY COMMENTS:
  1) change(85-07-21,ABall), approve(86-02-21,MCR7346),
     audit(86-07-29,Farley), install(86-08-01,MR12.0-1108):
     Modified to check for null rcse_ptr before referencing through during
     error handling.
  2) change(85-09-11,Fawcett), approve(85-09-11,MCR6979),
     audit(85-12-02,CLJones), install(86-03-21,MR12.0-1033):
     Add MCA and FIPS support
                                                   END HISTORY COMMENTS */

/****^ The rcp_id is used to generate a pointer to the RCS entry that is
       associated with this attachment request.  We will look in this RCS
       entry to obtain the information that describes the results of the
       attachment operation.  In the current implementation any assignment
       needed is performed by the attach call.  The attachment itself involves
       setting up communication with IOI.  For some devices there is the
       additional problem of mounting volumes.  The caller may be told to go
       blocked and call us back when he wakes up.  When the attachment is
       finally completed we will call IOI to set the limits for this device
       and to promote the device to the caller's validation level.  Then we
       will return the information that he needs in order to perform I/O on
       this device.  */

/*		ARGUMENT  DATA		*/

dcl	arg_comment	   char (*);		/* (O) RCP comment. */
dcl	arg_device_info_ptr	   ptr;			/* (I) Pointer to device info structure. */
dcl	arg_ecode		   fixed bin (35);		/* (O) Return error_table_ code. */
dcl	arg_ioi_index	   fixed bin;		/* (O) Index used to communicate with IOI. */
dcl	arg_rcp_id	   bit (36) aligned;	/* (I) RCP ID. */
dcl	arg_statex	   fixed bin;		/* (O) Caller's attachment state index. */
dcl	arg_timeout_max	   fixed bin (71);		/* (O) Max time-out value in microseconds. */
dcl	arg_workspace_max	   fixed bin (19);		/* (O) max size of IOI workspace in words. */


/*		AUTOMATIC  DATA		*/

dcl	console_is_free	   bit (1);		/* ON => OK to attach console... */
dcl	volume_offset	   bit (18) aligned;	/* Offset to volume entry for rcp_control_ */
dcl	device_offset	   bit (18) aligned;	/* Offset to device entry for rcp_control_ . */
dcl	process_id	   bit (36) aligned;	/* Process id makin the request to RCP. */
dcl	rcp_id		   bit (36) aligned;	/* Used to copy rcp_id argument. */

dcl	device_name	   char (32);		/* Device name for rcp_control_ */
dcl	operation		   bit (36) aligned;	/* Type of operation being requested of rcp_control_ */

dcl	caller_level	   fixed bin;		/* Caller's validation level. */
dcl	dcode		   fixed bin (35);		/* Dummy error code. */
dcl	dtypex		   fixed bin;		/* Device type index. */
dcl	ecode		   fixed bin (35);		/* error_table_ code. */
dcl	error_count	   fixed bin (17);		/* Error count for attachments needed by rcp_control_. */
dcl	ioi_index		   fixed bin;		/* IOI internal device index. */
dcl	statex		   fixed bin;		/* Caller's attachment state index. */
dcl	timeout_max	   fixed bin (71);		/* Max time-out interval in microseconds. */
dcl	workspace_max	   fixed bin (19);		/* Max IOI workspace size in words. */

dcl	arcse_ptr		   ptr;			/* Pointer to assignment RCS entry. */
dcl	device_info_ptr	   ptr;			/* Pointer to device info */
dcl	device_pointer	   ptr;
dcl	device_vol_ptr	   ptr;
dcl	rcp_data_pointer	   ptr;

/*		BASED  DATA		*/

dcl	1 arcse		   based (arcse_ptr) like rcse aligned;
						/* Used to reference assignment RCS entry. */



/*		INTERNAL STATIC DATA	*/



/*		EXTERNAL ENTRIES CALLED	*/

dcl	cleanup		   condition;		/* Used to set up a cleanup handler. */

dcl	(null, ptr, substr)	   builtin;

dcl	(
	error_table_$bad_arg,
	error_table_$invalid_state
	)		   fixed bin (35) external;

dcl	access_operations_$rcp_account
			   bit (36) aligned ext static;

dcl	rcp_pointers_$data	   entry () returns (ptr);
dcl	admin_gate_$console_free
			   entry (char (4), bit (1));
dcl	admin_gate_$ioi_promote
			   entry (fixed bin, fixed bin, fixed bin (35));
dcl	admin_gate_$ioi_set_to_max
			   entry (fixed bin, fixed bin (71), fixed bin (35));
dcl	admin_gate_$ioi_set_ws_max
			   entry (fixed bin, fixed bin (19), fixed bin (35));
dcl	clock_		   entry returns (fixed bin (71));
dcl	cu_$level_get	   entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	get_ring_		   entry returns (fixed bin);
dcl	ioi_$timeout	   entry (fixed bin, fixed bin (71), fixed bin (35));
dcl	rcp_detach_$detach	   entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));
dcl	rcp_device_info_$set   entry (ptr, ptr, fixed bin (35));
dcl	rcp_disk_		   entry (ptr, fixed bin (35));
dcl	rcp_control_	   entry (bit (36) aligned, bit (18) aligned, bit (18) aligned, char (*), fixed bin (17),
			   bit (36) aligned, fixed bin (35));
dcl	rcp_ioi_attach_	   entry (ptr, fixed bin (35));
dcl	rcp_tape_		   entry (ptr, fixed bin (35));
dcl	rcp_validate_	   entry (bit (36) aligned, fixed bin, ptr, fixed bin (35));
						/*						*/
%include rcp_com_seg;
%include rcp_data;

	volume_offset = ""b;
	device_offset = ""b;
	process_id = ""b;
	device_name = "";
	error_count = 0;
	ecode = 0;

	call cu_$level_get (caller_level);		/* Save caller's validation level. */
	on cleanup
	     begin;				/* If trouble cleanup. */
	     call cu_$level_set (caller_level);		/* Reset validation level. */
	end;
	call cu_$level_set (get_ring_ ());		/* Set validation level to RCP level. */

	rcp_id = arg_rcp_id;			/* Copy arguments. */
	device_info_ptr = arg_device_info_ptr;

	call rcp_validate_ (rcp_id, caller_level, rcse_ptr, ecode);
	if ecode ^= 0				/* Is RCP ID OK? */
	     then
	     goto ERROR;				/* No. */

	if rcse.kind ^= 1				/* Is this a device attachment RCS entry? */
	then do;					/* No, can't go on. */
	     ecode = error_table_$bad_arg;
	     goto ERROR;
	end;

	ecode = rcse.ecode;				/* Get code generated by rcp_control_. */
	if ecode ^= 0				/* Was there any error. */
	     then
	     goto ERROR;

	arcse_ptr = ptr (rcse_ptr, rcse.rcse_off);	/* Get pointer to assignment RCSE. */

	goto ATTACHMENT_STATE (rcse.state);		/* Check current state of attachment. */

ATTACHMENT_STATE (0):				/* FREE */
ATTACHMENT_STATE (1):				/* ASSIGNING */
ATTACHMENT_STATE (4):				/* ATTACHED */
ATTACHMENT_STATE (5):				/* COMPLETED */
	ecode = error_table_$invalid_state;
	goto ERROR;

ATTACHMENT_STATE (2):				/* ASSIGNED */
	if arcse.state ^= 5				/* Has assignment been completed? */
	then do;					/* No. */
	     ecode = arcse.ecode;			/* Get assignment error code. */
	     if ecode ^= 0				/* Any error in assignment? */
		then
		goto ERROR;			/* Yes, abort attachment. */
	     arcse.state = 5;			/* Indicate that assignment has been checked. */
	     arcse.state_time = clock_ ();
	end;
	rcse.state = 3;				/* Now attaching. */
	rcse.device_name = arcse.device_name;		/* Get name of assigned device. */
	rcse.device_off = arcse.device_off;		/* Copy rcp_data offset of assigned device. */
	rcse.flags.fips = arcse.flags.fips;		/* Copy fips flag */
	rcse.flags.no_protect = arcse.flags.no_protect;	/* Copy no_protect flag */
	rcse.flags.opr_int_available = arcse.flags.opr_int_available;
						/* Copy opr_int_available flag */

ATTACHMENT_STATE (3):				/* ATTACHING */
	dtypex = rcse.dtypex;			/* Get device type. */
	call ATTACH;				/* Perform the actual attachment. */
	if ecode ^= 0 then
	     goto ERROR;
	if rcse.state = 3				/* Are we still attaching? */
	then do;					/* Yes. */
	     statex = 1;				/* Caller should block and then call back. */
	     goto RETURN;
	end;

	ioi_index = rcse.ioi_index;			/* No, we can now complete the attachment. *. */
	rcs_ptr = ptr (rcse_ptr, "0"b);

	if (rcse.flags.volume) &			/* Did we assign a volume? */
	     (rcse.volume_name ^= "scratch")		/* That was not a scratch volume? */
	then do;					/* Yes, remember volume in assignment RCS entry. */
	     arcse.flags.volume = "1"b;
	     arcse.volume_name = rcse.volume_name;
	     arcse.label_type = rcse.label_type;
	     arcse.volume_density_index = rcse.volume_density_index;
	     arcse.need_auth = rcse.need_auth;
	end;

/*	Now complete the attachment by calling IOI to set the workspace and
   *	time-out limits and to promote the device.
*/
	if rcse.flags.priv				/* If  privileged attachment,      */
	     | rcse.flags.system			/* Or  system user.      */
	     then
	     workspace_max = rcs.ws_pmaxs (dtypex);	/* Then  give user large IOI workspace max. */

	else do;					/* A normal user. */
	     if USER_ON_WS_ACS ("01010"b) then
		workspace_max = rcs.ws_pmaxs (dtypex);	/* Then  give user large IOI workspace max. */
	     else workspace_max = rcs.ws_maxs (dtypex);	/* Else  give user normal IOI workspace max. */
	end;

	rcse.workspace_max = workspace_max;
	call admin_gate_$ioi_set_ws_max (ioi_index, workspace_max, ecode);
	if ecode ^= 0 then
	     goto ERROR;

	rcse.timeout_max,				/* Get and set max IOI time-out interval. */
	     timeout_max = rcs.to_maxs (dtypex);
	call admin_gate_$ioi_set_to_max (ioi_index, timeout_max, ecode);
	if ecode ^= 0 then
	     goto ERROR;
	if dtypex = 4 |				/* PRINTER */
	     dtypex = 5 |				/* PUNCH */
	     dtypex = 6				/* READER */
	then do;
	     call ioi_$timeout (ioi_index, timeout_max, ecode);
	     if ecode ^= 0 then
		go to ERROR;
	end;

	call admin_gate_$ioi_promote (ioi_index, rcse.caller_level, ecode);
	if ecode ^= 0 then
	     goto ERROR;

/* Return info about assigned device.  Passing a copy of arg_device_info_ptr is
   OK since rcp_device_info_ uses it to base a write-only structure. */

	call rcp_device_info_$set (device_info_ptr, ptr (rcse_ptr, rcse.rcse_off), ecode);
	if ecode ^= 0 then
	     goto ERROR;

	rcse.state = 5;				/* Attachment is now completed. */
	statex = 0;				/* Tell caller that it is complete. */
	arg_ioi_index = ioi_index;			/* Now we can return all the other info. */
	arg_workspace_max = workspace_max;
	arg_timeout_max = timeout_max;

/* Prepare for calling rcp_control_ */
	operation = access_operations_$rcp_account;
	volume_offset = rcse.volume_off;
	device_offset = rcse.device_off;
	call rcp_control_ (operation, volume_offset, device_offset, device_name, error_count, process_id, ecode);

	goto RETURN;

ERROR:						/* Abort this attachment. */
	if rcse_ptr ^= null () then
	     call rcp_detach_$detach (rcse.rcp_id, "0"b, 0, "", dcode);
	statex = 3;				/* Return error state. */

RETURN:						/* Return command args, reset validation level. */
	arg_comment = " ";
	arg_statex = statex;
	arg_ecode = ecode;
	call cu_$level_set (caller_level);
	return;					/*						*/
ATTACH:
     procedure;

/*	This procedure is called to perform the actual attachment via IOI.
   *	The processing to be done depends upon the device type.
*/

	goto DEVICE_TYPE (dtypex);			/* Process depending upon device type. */

DEVICE_TYPE (1):					/* TAPE */
	rcse.model = arcse.model;			/* Need model for tape attachment/mounting. */

	if rcse.flags.volume			/* Determine if preloading is allowed for this attachement. */
	     & arcse.flags.volume & rcse.volume_name = arcse.volume_name then
	     rcse.flags.preloaded = arcse.preload_allowed;

	call rcp_tape_ (rcse_ptr, ecode);		/* Perform tape attachment and mounting. */
	rcp_data_pointer = rcp_pointers_$data ();
	device_pointer = ptr (rcp_data_pointer, rcse.device_off);
	device_pointer -> device.flags.attached = "1"b;
	if rcse.flags.volume then
	     device_vol_ptr = ptr (rcp_data_pointer, rcse.volume_off);
	return;

DEVICE_TYPE (2):					/* DISK */
	rcse.model = arcse.model;			/* Need model for tape attachment/mounting. */

	if rcse.flags.volume			/* Determine if preloading is allowed for this attachement. */
	     & arcse.flags.volume & rcse.volume_name = arcse.volume_name then
	     rcse.flags.preloaded = arcse.preload_allowed;

	rcse.flags.not_removable_media = arcse.flags.not_removable_media;
	call rcp_disk_ (rcse_ptr, ecode);		/* Perform disk attachment and mounting. */
	rcp_data_pointer = rcp_pointers_$data ();
	device_pointer = ptr (rcp_data_pointer, rcse.device_off);
	device_pointer -> device.flags.attached = "1"b;
	if rcse.flags.volume then
	     device_vol_ptr = ptr (rcp_data_pointer, rcse.volume_off);
	return;

DEVICE_TYPE (3):					/* CONSOLE */
	call admin_gate_$console_free (substr (rcse.device_name, 1, 4), console_is_free);
	if ^console_is_free then do;
	     ecode = error_table_$invalid_state;
	     return;
	end;
DEVICE_TYPE (4):					/* PRINTER */
DEVICE_TYPE (5):					/* PUNCH */
DEVICE_TYPE (6):					/* READER */
DEVICE_TYPE (7):					/* SPECIAL */
DEVICE_TYPE (8):					/* MCA */
	call rcp_ioi_attach_ (rcse_ptr, ecode);		/* Attach the device in ring 0 via IOI. */
	rcse.state = 4;				/* Actual attachment has been performed. */

     end ATTACH;

/**/

USER_ON_WS_ACS:
     proc (test_access) returns (bit (1));

dcl	test_access	   bit (5);		/* access we are testing for, normally "rw" */
dcl	actual_access	   fixed bin (5);		/* access returned by hcs_$get_user_effmode. */

dcl	hcs_$get_user_effmode  entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, fixed bin (5),
			   fixed bin (35));

/* Note above that the "aligned" attributes are there only to get around the fact */
/* that the acs_directory and group_id are declared aligned in an include file.   */


dcl	bit		   builtin;

	call hcs_$get_user_effmode (rcs.acs_directory, "workspace.acs", rcse.group_id, rcse.caller_level, actual_access,
	     ecode);

	if ecode ^= 0 then do;
	     ecode = 0;				/* This isn't really an error */
	     return ("0"b);				/* Report failure */
	end;

	if (bit (actual_access, 5) & test_access) = test_access then
	     return ("1"b);				/* This process has at least "rw" access */
	else return ("0"b);				/* This process does not have "rw" access */

     end USER_ON_WS_ACS;

     end rcp_check_attach_;




		    rcp_check_attach_lv_.pl1        11/11/89  1110.3rew 11/11/89  0806.7       14229



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


rcp_check_attach_lv_:  procedure  (arg_rcp_id, arg_volume_info_ptr, arg_statex, arg_ecode);

/*	This procedure implements the rcp_$check_attach_lv entry.
*	Created on 04/08/76 by Bill Silver.
*	Modified 09/13/76 by Greenberg for lv_request_.
*
*	This procedure is basically a NOP.
*/

dcl	arg_rcp_id	bit(36) aligned;	/* (I) RCP ID of logical volume attachment. */
dcl	arg_volume_info_ptr	ptr;		/* (I) Not really used. */
dcl	arg_statex	fixed bin;	/* (O) 0 => OK,  3 => error. */
dcl	arg_ecode		fixed bin(35);

dcl	ecode		fixed bin(35);
dcl	lvid		bit(36) aligned;
dcl	rcp_id		bit(36) aligned;
dcl	statex		fixed bin;

dcl	rcp_lv_$check	entry  (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin(35));


	rcp_id = arg_rcp_id;
	call rcp_lv_$check (rcp_id, lvid, statex, ecode);

	if   ecode ^= 0
	then arg_statex = 3;
	else arg_statex = statex;
	arg_ecode = ecode;

	end  rcp_check_attach_lv_;




		    rcp_comment_.pl1                11/11/89  1110.3rew 11/11/89  0804.3       30483



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

/* format: off */

rcp_comment_:  procedure (arg_rcse_ptr);

/*	This program is an internal interface of RCP.
*	Created on 10/15/74 by Bill Silver.
*/


/****^  HISTORY COMMENTS:
  1) change(87-02-10,Farley), approve(87-04-14,MCR7652),
     audit(87-04-15,Lippard), install(87-04-28,MR12.1-1028):
     Removed the resetting of rcse.caller_comment so that it can be
     multiply displayed if required along with the check mount message.
                                                   END HISTORY COMMENTS */


/*	This program is called to display a comment on the operator's console.
*	We will call a special ring 1 interface to syserr using syserr code 0.
*	The comment that is displayed is taken from the specified RCS entry.
*	The format of the comment message seen by the operator is:
*
*		"RCP: Note (device_name) - comment"
*
*	The following rules are used to control the printing of the comment.
*	     1.	If the comment is blank it will not be displayed.
*	     2.	If the comment contains any bad characters they will be
*		converted to blanks.  The bad characters that we check 
*		for are all ASCII characters from (000) to (037) octal.
*	     3.	Once the comment is displayed it will be set to all
*		blanks so it will not be displayed again.
*/

dcl	arg_rcse_ptr	ptr;		/* (I) Pointer to specified RCS entry. */

dcl	converted_comment	char(64);		/* Used to convert bad characters. */
dcl	x		fixed bin;	/* Search variable. */

dcl     (	collate, search, substr, translate )  builtin;

dcl	admin_gate_$syserr  entry  options(variable);
%page;
%include rcp_com_seg;
%page;
/*	Begin rcp_comment_.
*/
	rcse_ptr = arg_rcse_ptr;		/* Get pointer to RCS entry. */

	if   rcse.caller_comment = " "	/* Is comment blank? */
	     then return;			/* Yes, don't display comment. */

					/* Look for bad characters. (000 - 037 octal) */
	x = search (rcse.caller_comment, substr(collate,1,31));
	if   x ^= 0			/* Are there any bad characters in comment? */
	     then do;			/* Yes, convert them to blanks. */
		converted_comment = translate(rcse.caller_comment, " ", substr(collate,1,31));
		rcse.caller_comment = converted_comment;
		if   rcse.caller_comment = " " /* Is comment blank now? */
		     then return;		/* Yes, then don't display it. */
	     end;

	call admin_gate_$syserr (0, "RCP: Note (^a) - ^a", rcse.device_name, rcse.caller_comment);
%page;
/* BEGIN MESSAGE DOCUMENTATION

Message:
RCP: Note (DEVICE) - COMMENT

S:	$info

T:	$run

M:	The user requesting the mounting of a
tape or disk pack on device specified a comment string.

A:	Read the comment.
It may describe special operator action,
such as where to find or send the volume.


END MESSAGE DOCUMENTATION */

	end  rcp_comment_;




		    rcp_compute_aim_mode.pl1        11/11/89  1110.3rew 11/11/89  0805.5       69885



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-07-06,Rauschelbach), approve(87-08-07,MCR7748),
     audit(87-11-11,Farley), install(87-11-30,MR12.2-1004):
     Changed to return error_table_$ai_restricted when access is denied for
     all cases, not just one. Removed signal to vfile_error condition as it
     was erroneously left from debugging.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_compute_aim_mode:
     procedure (a_req_info_ptr, a_res_info_ptr, a_aim_mode, a_error_code);

/*            This internal subroutine implements mandatory access
   *	    control (AIM) for RCP.
   *            Created 841112 by Maria M. Pozzo
   *
*/

/*                 ARGUMENT DATA                             */

dcl	a_req_info_ptr	   ptr;			/* (I) Points to requestor info */
dcl	a_res_info_ptr	   ptr;			/* (I) Points to resoruce info */
dcl	a_aim_mode	   bit (3);		/* (O) Raw AIM mode */
dcl	a_error_code	   fixed bin (35);		/* (O) Error code */

/*                 AUTOMATIC DATA                            */

dcl	aim_mode		   bit (3);		/* Local AIM mode */
dcl	temp_range	   (2) bit (72) aligned;
dcl	based_bits	   bit (bl * 9) aligned based (bp);
dcl	bl		   fixed bin (21);
dcl	error_code	   fixed bin (35);		/* Local error code */
dcl	bp		   ptr;
dcl	(addr, null, unspec)   builtin;

/*                 EXTERNAL ENTRIES                          */

dcl	aim_check_$range_in_range
			   entry ((2) bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned);
dcl	aim_check_$greater_or_equal
			   entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	aim_check_$equal	   entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	hcs_$get_authorization entry (bit (72) aligned, bit (72) aligned);
dcl	read_allowed_	   entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	write_allowed_	   entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

dcl	error_table_$ai_invalid_range
			   ext fixed bin (35) static;
dcl	error_table_$ai_out_range
			   ext fixed bin (35) static;
dcl	error_table_$ai_restricted
			   ext fixed bin (35) static;
dcl	error_table_$action_not_performed
			   ext fixed bin (35) static;
%page;
/* Copy arguments */

	requestor_info_ptr = a_req_info_ptr;
	resource_info_ptr = a_res_info_ptr;
	record_ptr = resource_info.registry_record_ptr;
	user_auth = requestor_info.current_authorization;

/* Initialize local variables */

	aim_mode = REW_ACCESS;			/* Assume REW initially */
	error_code, bl = 0;
	bp = null ();

/* If the resource is free, get the potential aim range found in the */
/* registry record; otherwise get the real aim range found in the */
/* registry record. */

	if registry_record.free then
	     call chase (registry_record.potential_aim_range_desc, bp, bl, error_code);
	else call chase (registry_record.aim_range_desc, bp, bl, error_code);
	if error_code ^= 0 then
	     goto MAIN_RETURN;
	if bl > 0 then addr (temp_range) -> based_bits = based_bits;
	else unspec (temp_range) = ""b;		/* no range, set to lowest possible */

/* If the low end of the AIM range is higher than us, then R access (and */
/* thus all access) is denied since we can't read up */

	if ^read_allowed_ (user_auth, temp_range (1)) then do;
	     aim_mode = N_ACCESS;
	     error_code = error_table_$ai_restricted;
	     goto MAIN_RETURN;
	end;

/* If the current authorization is not at the low end of the AIM range */
/* then E access is denied since allowing it anywhere else in the range */
/* could be a potential covert channel.  E access allows writing of */
/* protected attributes. */

	if ^aim_check_$equal (user_auth, temp_range (1)) then
	     aim_mode = aim_mode & RW_ACCESS;

/* If the high end of the AIM range is lower or disjoint then W access */
/* is denied since we can't write down.  We can still have R access and */
/* that is preserved, however, we must also deny E access since that */
/* allows writing of protected attributes and we have just been denied */
/* write access. */

	if ^write_allowed_ (user_auth, temp_range (2)) then
	     aim_mode = aim_mode & R_ACCESS;

MAIN_RETURN:
	if error_code ^= 0 then
	     aim_mode = N_ACCESS;
	a_aim_mode = aim_mode;
	a_error_code = error_code;
	return;

%page;
/* --------------------------------------------- */
permissible_aim:
     entry (max_range, aim_range, code);

/* This entry takes a pair of AIM access classes and determines
   whether the user should be allowed to place these
   AIM range on some RCP resource. */

dcl	(aim_range, max_range) (2) bit (72) aligned parameter;
dcl	user_auth		   bit (72) aligned;
dcl	code		   fixed bin (35);
dcl	rcp_priv		   bit (1) aligned;


	call hcs_$get_authorization (user_auth, (""b));
	rcp_priv = addr (user_auth) -> aim_template.privileges.rcp;

/* First and simplest check-- the high bounds must be >= the low bounds. */

	if ^aim_check_$greater_or_equal (max_range (2), max_range (1)) then do;
	     code = error_table_$ai_invalid_range;
	     goto permissible_aim_return;
	end;

	if ^aim_check_$greater_or_equal (aim_range (2), aim_range (1)) then do;
	     code = error_table_$ai_invalid_range;
	     goto permissible_aim_return;
	end;

/* Now check that the desired range "fits within" the max bounds. */

	if (^aim_check_$range_in_range (aim_range, max_range)) then do;
	     code = error_table_$ai_out_range;
	     goto permissible_aim_return;
	end;

/* Now we know that the ranges are self-consistent. */

	code = 0;

/* Now check to see whether this user has the ability to set these ranges. */

	if rcp_priv then
	     goto permissible_aim_return;

/* Make sure a user at a high authorization is not making a resource "suddenly
   appear" to someone at a lower authorization. */

	if ^write_allowed_ (user_auth, aim_range (1)) then do;
	     code = error_table_$ai_restricted;
	     goto permissible_aim_return;
	end;

/* We don't check upper bound.  Like creating directories, you can register a
   resource with an upper bound higher than you-- just don't expect to do
   anything else with it afterwards! */

permissible_aim_return:
	return;
%page;
/* ------------------------ */
chase:
     proc (descriptor, bp, bl, a_error_code);

dcl	(
	descriptor	   fixed bin (35),
	a_error_code	   fixed bin (35),
	bp		   pointer,
	bl		   fixed bin (21)
	)		   parameter;

dcl	1 rs		   like rs_info aligned automatic;
dcl	local_code	   fixed bin (35);

	a_error_code = 0;
	if descriptor = 0 then do;
	     bp = addr (bp);			/* gotta point somewhere */
	     bl = 0;
	     return;
	end;

	unspec (rs) = ""b;
	rs.version = rs_info_version_2;
	rs.locate_sw = "1"b;
	rs.descriptor = descriptor;
	local_code = 0;

	call iox_$control (resource_info.registry_switch_ptr, "record_status", addr (rs), local_code);
	if local_code ^= 0 then do;
	     a_error_code = error_table_$action_not_performed;
	     return;
	end;
	bl = rs.record_length;
	bp = rs.record_ptr;
	return;
     end chase;					/* ------------------------------- */
%page;
%include access_mode_values;
%page;
%include aim_template;
%page;
%include iox_dcls;
%page;
%include rcp_requestor_info;
%page;
%include rcp_resource_info;
%page;
%include rcp_registry;
%page;
%include rs_info;
     end rcp_compute_aim_mode;




		    rcp_compute_bracket_mode.pl1    11/11/89  1110.3rew 11/11/89  0807.0       37044



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-07-12,Pozzo), approve(86-08-13,MCR7510),
     audit(86-08-13,EJSharpe), install(86-08-19,MR12.0-1120):
     Modified to initialize the variable local_bracket_mode.
     Change name and date are guesses.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_compute_bracket_mode:
     procedure (a_acs_path, a_requestor_info_ptr, a_resource_info_ptr, a_bracket_mode, a_rbs, a_error_code);

/*            This internal subroutine implements intraprocess access
   *	    computations (ring brackets) for RCP.
   *            Created 841030 by Maria M. Pozzo
   *
   *            If the ACS segment exists as found in a_acs_path, then get
   *            the ring brackets from the ACS segment and set access as follows:
   *                user validation in 0-r1 ---- REW
   *                user validation in 0-r2 ---- R
   *	    If the ACS segment does not exist, then this check is bypassed.
*/

/*                        ARGUMENT DATA                          */

dcl	a_requestor_info_ptr   ptr;			/* (I) Pointer to information about the real requestor of the RCP operation - not Initializer. */
dcl	a_resource_info_ptr	   ptr;			/* (I) Pointer to information about the resource being requested */
dcl	a_acs_path	   char (168);		/* (I) Pathname of the associated ACS segment */
dcl	a_bracket_mode	   bit (3);		/* (O) Resulting discretionary access mode of requestor to resource */
dcl	a_rbs		   (2) fixed bin (3);	/* (O) The ring brackets of the ACS segment if they exist. */
dcl	a_error_code	   fixed bin (35);		/* (O) Error code */


/*                      AUTOMATIC                    */

dcl	local_bracket_mode	   bit (3);		/* Internal bracket mode */

dcl	acs_path		   char (168);		/* ACS pathname */
dcl	registry_dir	   char (64);		/* Registry directory */

dcl	error_code	   fixed bin (35);		/* Error code */
dcl	user_level	   fixed bin (3);		/* Validation level of caller */
dcl	resource_ring_brackets (3) fixed bin (3);	/* Ring brackets of resource */


/*                      ENTRIES CALLED               */

dcl	hcs_$get_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));

/*                      ERROR ENTRIES                */

dcl	error_table_$resource_bad_access
			   fixed bin (35) ext static;

%page;

/*  Copy input arguments */

	acs_path = a_acs_path;
	requestor_info_ptr = a_requestor_info_ptr;
	resource_info_ptr = a_resource_info_ptr;

/* Initialize local variables and get set up */

	error_code = 0;
          local_bracket_mode = "000"b;
	user_level = requestor_info.validation_level;
	registry_dir = resource_info.registry_dir;

/*  Find out the ACS segment ring brackets. */

	call hcs_$get_ring_brackets (a_acs_path, "", resource_ring_brackets, error_code);
	if error_code ^= 0 then
	     goto MAIN_RETURN;
	a_rbs (1) = resource_ring_brackets (1);
	a_rbs (2) = resource_ring_brackets (2);

/*  See if we are in the read (R) bracket 0-r2 */

	if user_level <= resource_ring_brackets (2) then
	     local_bracket_mode = R_ACCESS;

/* See if we are in the executive/write bracket (EW) which also implies R bracket. */

	if user_level <= resource_ring_brackets (1) then
	     local_bracket_mode = local_bracket_mode | REW_ACCESS;

MAIN_RETURN:
	if local_bracket_mode = N_ACCESS then
	     error_code = error_table_$resource_bad_access;
	a_bracket_mode = local_bracket_mode;
	a_error_code = error_code;
	return;

%page;
%include access_mode_values;
%page;
%include rcp_requestor_info;
%page;
%include rcp_resource_info;

     end rcp_compute_bracket_mode;




		    rcp_compute_raw_mode.pl1        11/11/89  1110.3rew 11/11/89  0804.6       49770



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_compute_raw_mode:
     procedure (a_rm_on, a_requestor_info_ptr, a_resource_info_ptr, a_acs_path, a_owner, a_raw_mode, a_error_code);

/****^ This internal subroutine implements discretionary access
       computations for RCP.
       Created 841025 by Maria M. Pozzo */


/****^  HISTORY COMMENTS:
  1) change(85-07-12,Pozzo), approve(86-02-21,MCR7346), audit(86-07-29,Farley),
     install(86-08-01,MR12.0-1108):
     Modified to allow owners to retain REW access if the ACS specified in the
     registry does not exist.
                                                   END HISTORY COMMENTS */


/****^ If Resource Management is DISABLED, simply get the ACL from
        the ACS segment located in >sc1>rcp.
       If Resource Management is ENABLED, and there is an ACS segment
        set the access from the ACL of the ACS segment.
       If there is no ACS, get the resource owner from the registry
        and set as follows:
               owner = user_id           REW owner
                                         NULL world
               owner = free              NULL world
               owner = system            NULL world */

/*                        ARGUMENT DATA                          */

dcl	a_rm_on		   bit (1) aligned;		/* (I) "1"b means Resource Management is Enabled. */
dcl	a_requestor_info_ptr   ptr;			/* (I) Pointer to information about the real requestor of the RCP operation - not Initializer. */
dcl	a_resource_info_ptr	   ptr;			/* (I) Pointer to information about the resource being requested */
dcl	a_acs_path	   char (168);		/* (I) Pathname of the associated ACS segment */
dcl	a_owner		   char (32);		/* (I/O) Owner of the resource */
dcl	a_raw_mode	   bit (3);		/* (O) Resulting discretionary access mode of requestor to resource */
dcl	a_error_code	   fixed bin (35);		/* (O) Error code */


/*                      AUTOMATIC                    */

dcl	local_raw_mode	   bit (3);		/* Local raw mode */
dcl	rm_on		   bit (1) aligned;		/* ON=> Resource Management enabled */
dcl	temp_mode		   bit (36) aligned;	/* Conversion of modes */
dcl	is_volume		   bit (1);		/* ON=> resource type is volume */

dcl	acs_path		   char (168);		/* ACS path name */
dcl	owner		   char (32) varying;	/* Resource owner */
dcl	registry_dir	   char (64);		/* Registry directory */
dcl	user		   char (32);		/* User id */

dcl	error_code	   fixed bin (35);


/*                      EXTERNAL STATIC              */

dcl	error_table_$resource_bad_access
			   fixed bin (35) ext static;
dcl	error_table_$resource_unknown
			   fixed bin (35) ext static;

/*                      BUILTINS                     */

dcl	(length, rtrim, substr)
			   builtin;

/*                      ENTRIES CALLED               */

dcl	hcs_$get_user_raw_mode entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35));
dcl	resource_info_$get_type
			   entry (char (*), bit (1), fixed bin (35));
%page;
/* Copy input arguments */

	rm_on = a_rm_on;
	requestor_info_ptr = a_requestor_info_ptr;
	resource_info_ptr = a_resource_info_ptr;
	acs_path = a_acs_path;
	owner = a_owner;

/* Initialize local variables and get set up */

	local_raw_mode = N_ACCESS;
	temp_mode = (36)"0"b;
	error_code = 0;

/* The user is in the form of *.*.* and the owner is in */
/* the form *.* in the registry so must strip user of tag. */

	user = substr (requestor_info.user_id, 1, length (rtrim (requestor_info.user_id)) - 2);
	registry_dir = resource_info.registry_dir;

/* Is Resource Management Enabled */

	if (rm_on & acs_path = "") then do;
	     if owner = user then			/* Owner gets REW */
		local_raw_mode = REW_ACCESS;
	     else local_raw_mode = N_ACCESS;		/* NULL access to world */
	end;
	else if (acs_path ^= "") then do;		/* We have an ACS path */
	     call hcs_$get_user_raw_mode (acs_path, "", (requestor_info.user_id), temp_mode, error_code);

/*  If the access on the acs_path cannont be determined (i.e. it */
/*  doesn't exist or something) the owner should retain REW. */

	     if error_code ^= 0 then
		if user = owner then do;
		     local_raw_mode = REW_ACCESS;
		     error_code = 0;
		end;
		else goto MAIN_RETURN;
	     else local_raw_mode = substr (temp_mode, 1, 3);
	end;
	else do;

/*  We know there's no ACS and RM is disabled */

	     call resource_info_$get_type (resource_info.resource_type, is_volume, error_code);
	     if error_code ^= 0 then
		goto MAIN_RETURN;
	     if is_volume then
		local_raw_mode = RW_ACCESS;		/* Everyone has RW to volumes */

/* At this point it is not a volume and there is no */
/* ACS for it so it is not a known resource. */

	     else error_code = error_table_$resource_unknown;
	end;

MAIN_RETURN:
	if local_raw_mode = N_ACCESS then
	     error_code = error_table_$resource_bad_access;
	a_raw_mode = local_raw_mode;
	a_error_code = error_code;
	return;
%page;
%include access_mode_values;
%page;
%include rcp_requestor_info;
%page;
%include rcp_resource_info;
%page;
%include rcp_registry;

     end rcp_compute_raw_mode;




		    rcp_control_.pl1                11/11/89  1110.3rew 11/11/89  0806.7      491463



/****^  ***********************************************************
        *                                                         *
        * 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(85-09-11,Fawcett), approve(85-09-11,MCR6979),
     audit(85-12-02,CLJones), install(86-03-21,MR12.0-1033):
     Add support for FIPS
     and IMU
  2) change(86-08-07,Farley), approve(86-08-07,MCR7448),
     audit(86-10-20,Beattie), install(86-10-28,MR12.0-1200):
     Changed DELETE_DEVICE to unload the device BEFORE deleting it. Changed
     TEST_DEVICE to set priv_gate_call to OFF, even when called through
     rcp_priv_. Changed ASSIGN to properly unassign the volume when the device
     assignment fails.
  3) change(87-01-27,Farley), approve(87-04-06,MCR7650),
     audit(87-04-15,Dickson), install(87-04-28,MR12.1-1028):
     Changed to reset device.flags.attached before unloading the volume from
     the device.  This is required when the device is still assigned.
  4) change(87-06-25,Rauschelbach), approve(87-06-29,MCR7736),
     audit(87-07-21,Farley), install(87-08-06,MR12.1-1063):
     The error error_table_$resource_unknown was replaced with a new error code
     error_table_$no_appropriate_device for the instance of mismatched device
     and volume attributes.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_control_:
     procedure (a_operation, a_volume_offset, a_device_offset, a_device_name, a_error_count, a_process_id, a_ecode);

/*	This program is an internal interface of RCP.
   *	Created on 11/27/74 by Bill Silver
   *
   *      This routine performs the following functions:
   *	     1.	Assign a device and/or volume.
   *	     2.	Update the error count for the specified device.
   *	     3.	Unassign a device and/or volume.
   *	     4.	Forcedly unassign a device.
   *	     5.	Unassign all resources of specified process.
   *	     6.   Delete a device.
   *	     7.	Add a device.
*/
/*	Tape survey when adding drive by C. Hornig, September 1982.
   *      Modified 12/8/83 by B. Braun to correct all device requests being denined (phx12105).
   *	Modified 1/84 by Chris Jones to tell IOI what we've done about adding or deleting a device.
   *	Modified 840521 for console addition / deletion... -E. A. Ranzenbach
   *      Modified 841004 to change the name to rcp_control, to allow the
   *       routine to accept arguments instead of a 72-bit message, and
   *       perform some general cleanup...- M. M. Pozzo
   *      Modified 850131 to interface with the new rcp_access_kernel_ for the
   *       B2 effort...-M. M. Pozzo
   *      Modified 1985-03-08, BIM: check console state.
   *      Modified 1985-03-14, BIM: cleanup journals, translate "record not found" into "no such resource".
   *	Modified 03/18/85 by Chris Jones to not delete devices until after their volumes are unloaded.
   *	Modified 1985-04-3 by Paul Farley & Fawcett to add FIPS support and
   *		             add no_protect and opr_int_available code
   *      Modified 1985-04-11, BIM&MMP: Don't zero error code before testing it in TEST_DEVICE.
   *               Also audit mounts of volumes.
   *      Modified 1985-04-12, BIM: ioi delete device at unassign time
   *	   that was added at assign time due to use of rcp_priv_ to assign
   *	   a deleted device.
*/
%page;
/*		ARGUMENT  DATA		*/

dcl	a_operation	   bit (36) aligned;	/* Specifies the type of operation being requested */
dcl	a_volume_offset	   bit (18) aligned;	/* Offset to volume information */
dcl	a_device_offset	   bit (18) aligned;	/* Offset to device information */
dcl	a_device_name	   char (*);		/* Drive name */
dcl	a_error_count	   fixed bin (17);		/* Error count for device attachments */
dcl	a_process_id	   bit (36) aligned;	/* Process id for which this operation is being performed */
dcl	a_ecode		   fixed bin (35);		/* Error code */


dcl	a_add_sw		   bit (1) aligned;		/* For $ss_io_interchange, "1"b = add to RCP */
dcl	a_del_sw		   bit (1) aligned;		/* For $ss_io_interchange, "1"b to 'add' in deleted state */


/*		AUTOMATIC  DATA		*/


dcl	access		   bit (3) aligned;		/* User's access to resource. */
dcl	effmode		   bit (3);
dcl	accessible_flag	   bit (1) aligned;		/* ON => process has access to a segment. */
dcl	add_sw		   bit (1) aligned;		/* For $ss_io_interchange, "1"b => add to RCP. */
dcl	available_flag	   bit (1) aligned;		/* ON => device is available. */
dcl	console_free	   bit (1) aligned;		/* flag indicating that the ocdcm_ willlet us have the console. */
dcl	del_sw		   bit (1) aligned;		/* For $ss_io_interchange, "1"b to 'add' in deleted state */
dcl	full		   bit (1) aligned;		/* "1"b if available_list array is full */
dcl	match_flag	   bit (1) aligned;		/* ON => device matches. */
dcl	system_flag	   bit (1) aligned;		/* ON => process is a system process. */
dcl	volume_flag	   bit (1) aligned;		/* ON => we have assigned a volume. */
dcl	temp_mode		   bit (3);
dcl	dev_rcse_off	   bit (18) aligned;	/* Offset of RCS device entry. */
dcl	device_off	   bit (18) aligned;	/* Offset of RCPD device entry. */
dcl	vol_rcse_off	   bit (18) aligned;	/* Offset of RCS volume entry. */
dcl	volume_off	   bit (18) aligned;	/* Offset of RCPD volume entry. */
dcl	process_id	   bit (36) aligned;	/* Process ID. */

dcl	operation		   bit (36) aligned;	/* Operation.   */
dcl	base_op		   bit (36) aligned;	/* the basic operation */
dcl	device_name	   char (32);		/* Device name. */
dcl	volume_name	   char (32);		/* Volume name. */
dcl	who_am_i		   char (32);		/* Identifies this program. */

dcl	dtypex		   fixed bin;		/* Device type index. */
dcl	ecode		   fixed bin (35);		/* error_table_ code. */
dcl	error_count	   fixed bin (17);		/* error count for device attachments */
dcl	num_assigned	   fixed bin;		/* Number of devices assigned to a process. */
dcl	num_avail_nres	   fixed bin;		/* Number of non reservable devices available. */
dcl	num_available	   fixed bin;		/* Number of devices available for assignment. */
dcl	num_free_res	   fixed bin;		/* Number of reservable devices currently free. */
dcl	num_reserved	   fixed bin;		/* Number of devices reserved to system processes. */
dcl	num_resvd		   fixed bin;		/* Number of device reserved for this process. */
dcl	one_was_accessible	   bit (1) aligned;		/* at least one was accessible */
dcl	one_was_appropriate	   bit (1) aligned;		/* at least one was appropriate (but perhaps inaccessible or unavailable) */
/**** there is no one_was_available, since available is conditional on the other two PLUS resource limits. */
dcl	time_assigned	   fixed bin (71);		/* Used to compute metering data. */

dcl	record_ptr	   ptr;			/* Pointer to the registry resource record. */
dcl	reg_iocb_ptr	   ptr;			/* IOCB for the registry. */
dcl	save_device_ptr	   ptr;			/* Used to save pointer to assigned device. */
dcl	trans_iocb_ptr	   ptr;			/* IOCB for the transaction control file. */
dcl	available_list	   (MAX_AVAILABLE) ptr;	/* List of appropriate, accessible, and available devices. */
dcl	1 req_info	   like requestor_info automatic;
						/* Requestor information for determining RCP access */
dcl	1 res_info	   like resource_info automatic;
						/* Resource information for determining RCP access */

/*		CONSTANTS			*/


dcl	MAX_AVAILABLE	   fixed bin (17) static internal options (constant) init (128);
dcl	DEFAULT_REGISTRY_DIR   char (64) static internal options (constant) init (">sc1>rcp");

/*		CONDITIONS		*/


dcl	cleanup		   condition;		/* Used to establish a cleanup handler. */


/*		BUILTIN FUNCTIONS		*/


dcl	(addr, clock, divide, hbound, length, null, ptr, rel, string, substr, unspec)
			   builtin;


/*		ERROR CODES		*/


dcl	error_table_$no_key	   fixed bin (35) ext static;
dcl	error_table_$resource_unassigned
			   fixed bin (35) ext;
dcl	error_table_$device_deletion_deferred
			   fixed bin (35) ext;
dcl	error_table_$device_limit_exceeded
			   fixed bin (35) ext;
dcl	error_table_$invalid_state
			   fixed bin (35) ext;
dcl	error_table_$io_still_assnd
			   fixed bin (35) ext;
dcl	error_table_$notalloc  fixed bin (35) ext;
dcl	error_table_$resource_bad_access
			   fixed bin (35) ext;
dcl	error_table_$resource_unavailable
			   fixed bin (35) ext;
dcl	error_table_$resource_unknown
			   fixed bin (35) ext;
dcl       error_table_$no_appropriate_device
                                 fixed bin (35) ext;
dcl	error_table_$unsupported_operation
			   fixed bin (35) ext;

dcl	access_operations_$rcp_assign_read
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_assign_write
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_add_device
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_delete_device
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_error_count
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_account
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_unassign
			   bit (36) aligned ext static;

/*		EXTERNAL ENTRIES CALLED	*/


dcl	admin_gate_$console_free
			   entry (char (4) aligned, bit (1) aligned);
dcl	admin_gate_$ocdcm_reconfigure
			   entry (char (4) aligned, fixed bin, fixed bin (35));
dcl	admin_gate_$ioi_add_device
			   entry (char (*), fixed bin (35));
dcl	admin_gate_$ioi_delete_device
			   entry (char (*), fixed bin (35));
dcl	admin_gate_$syserr	   entry options (variable);
dcl	get_group_id_	   entry () returns (char (32));
dcl	get_process_id_	   entry returns (bit (36));
dcl	hcs_$wakeup	   entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl	rcp_access_kernel_	   entry (bit (36) aligned, ptr, ptr, bit (3), fixed bin (35));
dcl	rcp_lock_$lock	   entry (ptr, fixed bin (35));
dcl	rcp_lock_$unlock	   entry (ptr);
dcl	rcp_match_$match	   entry (ptr, ptr) returns (bit (1));
dcl	rcp_match_$select	   entry (ptr, fixed bin, char (*) aligned, ptr);
dcl	rcp_match_user_name_   entry (char (32) aligned, char (32) aligned) returns (bit (1));
dcl	rcp_pointers_$com_seg  entry returns (ptr);
dcl	rcp_pointers_$data	   entry returns (ptr);
dcl	rcp_tape_survey_	   entry (char (*), fixed bin, bit (1) aligned, bit (1) aligned, (4) fixed bin (35),
			   fixed bin (35));
dcl	rcp_unload_$unload_device
			   entry (ptr, bit (1));
dcl	get_authorization_	   entry () returns (bit (72) aligned);
dcl	hcs_$get_authorization entry (bit (72) aligned, bit (72) aligned);
dcl	rcp_get_scratch_volume_
			   entry (ptr, char (*), bit (3) aligned, fixed bin (35));
dcl	rcp_cancel_resource_   entry (char (*), char (*), fixed bin (35));
%page;
/*        This routine has two entry points.  rcp_control_$ss_io_interchange is called by mdx.pl1.  The main entry point will determine what functions to perform from the operation argument.  RCPD will be locked while it is being manipulated. */

/**** NOTES
      device.unassign_state, device.delete, device.priv:

      These three variables overlap. device.unassign_state should always
      be the correct value for device.state after the completion of unassign.
      However, if device.delete is on, then the device must be marked
      DELETED at unassign. However, unassign_state is not changed
      when a deletion is requested for an assigned or reserved device,
      so that if the device is added back before it is unassigned
      things will work correctly.

      If device.priv is on, then unassign_state
      = DELETED implies that the device was deleted to begin with and assigned
      with rcp_priv_, rather than deleted by the operator during the
      assignment. The only implication of this is that unloads are not
      attempted at unassignment. */

	operation = a_operation;			/* Copy args */
	base_op = basic_operation (operation);
	ops_ptr = addr (addr (operation) -> encoded_access_op.detailed_operation);
	error_count = a_error_count;

	who_am_i = "rcp_control_";
	rcpd_ptr = rcp_pointers_$data ();		/* Set up pointers. */
	rcs_ptr = rcp_pointers_$com_seg ();
	reg_iocb_ptr, trans_iocb_ptr = null ();
	ecode = 0;

	on cleanup
	     begin;
	     call cleanup_kernel_call ((0));
	     call UNLOCK;				/* If trouble unlock rcp_data. */
	end;

	call rcp_lock_$lock (addr (rcpd.lock_info), ecode);
	if ecode ^= 0 then do;
	     a_ecode = ecode;
	     return;
	end;

	if (base_op = access_operations_$rcp_assign_read) | (base_op = access_operations_$rcp_assign_write) then
	     call ASSIGN;
	else if base_op = access_operations_$rcp_error_count then
	     call ERROR_COUNT;
	else if base_op = access_operations_$rcp_unassign then
	     call UNASSIGN;
	else if base_op = access_operations_$rcp_delete_device then
	     call DELETE_DEVICE;
	else if base_op = access_operations_$rcp_add_device then
	     call ADD_DEVICE;
	else if base_op = access_operations_$rcp_account then
	     call ACCOUNT_ATTACH;
	else ecode = error_table_$unsupported_operation;

	call UNLOCK;
	a_ecode = ecode;

	return;
%page;
UNLOCK:
     procedure;					/* Unlock RCPD. */
	call rcp_lock_$unlock (addr (rcpd.lock_info));
     end UNLOCK;
%page;
ASSIGN:
     procedure;

/*	This procedure is called to perform an assignment of a device
   and/or volume.
   The offsets provided as input determine what is to be assigned.
   These offsets reference RCS entries.  We will communicate the
   results of the assignment(s) by filling in these entries.
*/

	vol_rcse_off = a_volume_offset;		/* Copy args */
	dev_rcse_off = a_device_offset;

	volume_flag = "0"b;				/* Assume no volume assigned. */

	if vol_rcse_off ^= "0"b			/* Do we have to assign a volume? */
	then do;					/* Yes. */
	     call ASSIGN_VOLUME;			/* Assign one volume to this process. */
	     rcse.ecode = ecode;			/* Tell results of volume assignment. */
	     if ecode ^= 0				/* Any problems with volume? */
		then
		return;				/* Yes, abort all assignments. */
	end;

	if dev_rcse_off ^= "0"b			/* Do we have a device to assign? */
	then do;					/* Yes. */
	     base_op = access_operations_$rcp_assign_write;
						/* Always assign a device for writing. */
	     call ASSIGN_DEVICE;			/* Assign an appropriate device. */
	     rcse.ecode = ecode;			/* Tell results of device assignment. */
	end;

	if ^volume_flag				/* Device assignment done.  Was there a volume? */
	     then
	     return;				/* No, nothing else to do. */

	if ecode ^= 0				/* Was there an error assigning device? */
	then do;					/* Yes. */
	     call UNASSIGN_VOLUME ();
	     return;
	end;

	if dev_rcse_off = "0"b			/* Was a device just assigned? */
	then do;					/* No, put volume on previously assigned device. */
	     rcse_ptr = ptr (rcs_ptr, vol_rcse_off);	/* Attachment RCS entry. */
	     rcse_ptr = ptr (rcs_ptr, rcse.rcse_off);	/* Assignment RCS entry. */
	     device_ptr = ptr (rcpd_ptr, rcse.device_off);
	     dtypex = device.dtypex;			/* Get device type of this device. */
	     dtype_ptr = addr (rcpd.dtype (dtypex));
	end;

	if device.volume_name = volume_name		/* Is volume already on this device? */
	then do;					/* Yes, nothing more to do. */
	     rcse.volume_name = volume_name;		/* ASSIGNment RCSE */
	     return;
	end;

	if volume_name = "scratch"			/* Is this a scratch volume. */
	then do;					/* Yes, special case. */
	     device.volume_name = " ";		/* Scratch volumes not remembered. */
	     return;
	end;

/*	The assigned volume is being put on a new device.  We must search through
   *	all of the devices of this type to see if it is currently on any other
   *	device.  If it is we will remove it from that device.
*/
	save_device_ptr = device_ptr;			/* Save pointer to assigned device. */
	device_off = dtype.first_off;			/* Get first device of this type. */
	do while (device_off ^= "0"b);		/* Test all devices of this type. */
	     device_ptr = ptr (rcpd_ptr, device_off);
	     if device.volume_name = volume_name then do; /* We found the volume on another device. */
		device.flags.attached = "0"b;		/* Mark it as _n_o_t attached. */
		call rcp_unload_$unload_device (device_ptr, "0"b);
						/* unload the volume */
		device.volume_name = "";		/* Forget this occurance. */
		goto REMEMBER_DEVICE;		/* No need to test any more devices. */
	     end;
	     device_off = device.next_off;		/* Test next device. */
	end;

REMEMBER_DEVICE:					/* Put volume on assigned device. */
	save_device_ptr -> device.volume_name = volume_name;

     end ASSIGN;
%page;
/*	This procedure is called to assign a volume.  The assignment of a volume
   *	is independent of the assignment of a device.  A list of the currently
   *	assigned volumes is kept in RCPD.
*/


ASSIGN_VOLUME:
     procedure;

dcl	i		   fixed bin;
dcl	ignored_code	   fixed bin (35);

	rcse_ptr = ptr (rcs_ptr, vol_rcse_off);		/* Get pointer to RCS entry that => volume. */
	access = "000"b;
	if rcse.volume_name ^= "scratch" then
	     volume_name = rcse.volume_name;
	else do;
	     call rcp_get_scratch_volume_ (rcse_ptr, volume_name, access, ecode);
	     if ecode ^= 0 then
		return;
	     rcse.volume_name = volume_name;
	end;
	volume_off = "0"b;				/* Initialize volume offset. */

	do i = 1 to rcpd.last_volume;			/* Search through list of volumes. */
	     volume_ptr = addr (rcpd.volume (i));	/* Get pointer to volume entry. */
	     if volume.volume_name = volume_name then do;
		if (volume.state = FREE) | ((volume.state = RESERVED) & (volume.process_id = rcse.process_id)) then
		     volume_off = rel (volume_ptr);
		else if volume_name ^= "" then do;
		     ecode = error_table_$resource_unavailable;
		     return;
		end;
	     end;
	     else if (volume.state = FREE) & (volume.volume_name = "") then
						/* If this is a free entry in the table ... */
		if volume_off = "0"b then		/* ... and we don't have a slot to use yet ... */
		     volume_off = rel (volume_ptr);	/* ... then remember this one for later. */
	end;

	if volume_off = "0"b			/* Volume not found, room for another? */
	     then
	     if rcpd.last_volume >= rcpd.tot_volumes then do;
						/* No room. */
		ecode = error_table_$notalloc;
		return;
	     end;
	     else do;				/* Get a new entry. */
		rcpd.last_volume = rcpd.last_volume + 1;
		volume_off = rel (addr (rcpd.volume (rcpd.last_volume)));
	     end;

/*	Now we must make sure we have access to the volume requested.
*/
	if access = "000"b then do;			/* Don't know yet. */
	     call setup_kernel_call ((VOLUME_TYPE (rcse.dtypex)), rcse.volume_name, ecode);
	     if ecode ^= 0 then
		return;
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), effmode, ecode);
	     if ecode ^= 0 then
		if (ecode = error_table_$resource_unknown) & (rcpd.modes.auto_registration) then do;
		     rcse.flags.must_auto_register = "1"b;
		     access = REW_ACCESS;
		     ecode = 0;
		     call cleanup_kernel_call (ignored_code);
		end;
		else do;
		     call cleanup_kernel_call (ignored_code);
		     return;
		end;
	     else do;
		access = effmode;
		call cleanup_kernel_call (ignored_code);
	     end;
	end;


/*	Assign volume by filling in the free volume entry that we have found.
*/
	volume_ptr = ptr (rcpd_ptr, volume_off);	/* Get pointer to assigned volume entry. */
	volume.process_id = rcse.process_id;		/* Assign volume entry to process. */
	volume.vtypex = rcse.dtypex;
	volume.unassign_state = volume.state;
	volume.state = ASSIGNED;			/* Make it assigned. */
	volume.state_time = clock ();
	volume.volume_name = volume_name;
	volume.group_id = rcse.group_id;
	if volume.unassign_state = FREE then do;	/* if this was free ... */
	     volume.reserved_by = "";			/* no reservation */
	     volume.reservation_id = 0;
	end;
	volume.current_authorization = get_authorization_ ();
						/* Save this guy's authorization. */

	volume_name = rcse.volume_name;		/* Leave the real volume name here. */
	volume_flag = "1"b;				/* ON => a volume has been assigned. */
	rcse.state = 2;				/* State => volume now assigned. */
	rcse.volume_off = volume_off;			/* Save offset of volume entry. */

     end ASSIGN_VOLUME;
%page;
ASSIGN_DEVICE:
     procedure;

dcl	ignored_code	   fixed bin (35);
dcl	(i, j)		   fixed bin;

/*	This procedure is called to assign a device.  The following tests
   *	are made before assigning a device:
   *	     1.	There must be an appropriate device.
   *	     2.	The requesting process must have access to the device.
   *	     3.  	There must be an appropriate and accessible device that is available.
   *	     4.	The device limits must not be exceeded.
   *	     5.	If the assignment is based on a volume then we will try to
   *		find a device that has the specified volume already mounted.
   *	     6.	Otherwise we take the device that has been unassigned the longest.
*/
	rcse_ptr = ptr (rcs_ptr, dev_rcse_off);		/* Get pointer to RCS entry for device. */
	dtypex = rcse.dtypex;			/* Get device type index. */
	dtype_ptr = addr (rcpd.dtype (dtypex));		/* Get pointer to device type entry. */
	system_flag = rcse.flags.system;		/* Get system flag. */
	if rcse.group_id = "Initializer.SysDaemon.z" & rcse.caller_level = 1 then
	     system_flag = "1"b;

	num_assigned,				/* Initialize counters. */
	     num_free_res, num_reserved, num_resvd = 0;
	one_was_accessible, one_was_appropriate = "0"b;
	num_available = 0;

	device_off = dtype.first_off;			/* Start with first type of device. */
	full = "0"b;				/* available_list array is empty. */
	do while ((device_off ^= "0"b) & (^full));	/* Test all devices of this type until the available_list array is full. */
	     device_ptr = ptr (rcpd_ptr, device_off);	/* Get pointer to RCPD device entry. */
	     call TEST_DEVICE;			/* Test device to see if it can be assigned. */
	     device_off = device.next_off;		/* Get offset of next device of this type. */
	end;

	if num_available = 0			/* none to return */
	then do;					/* select the error code */
	     if ^one_was_appropriate then
		ecode = error_table_$no_appropriate_device;
	     else if ^one_was_accessible then
		ecode = error_table_$resource_bad_access;
	     else ecode = error_table_$resource_unavailable;
						/* there was one that we would have access too, but we couldn't have it */
	     return;
	end;

	call CHECK_LIMITS;				/* Check device limits. */
	if ecode ^= 0 then
	     return;				/* Find the best device that matched. */
	if num_resvd > 0 then do;
	     j = 0;
	     do i = 1 to num_available;
		if available_list (i) -> device.state = RESERVED then do;
		     j = j + 1;
		     if i ^= j then
			available_list (j) = available_list (i);
		end;
	     end;
	     num_available = j;
	end;

	call rcp_match_$select (addr (available_list), num_available, rcse.volume_name, device_ptr);
	device_off = rel (device_ptr);		/* Save offset of device entry. */

/* When searching for any device, auditing is done after selection. */
/* Call the kernel to perform the auditing since it has all the */
/* information needed to do it.  */

	if (^rcse.flags.device & rcpd.modes.resource_mgmt_enabled) then do;
	     detailed_operation.search = "0"b;
	     call setup_kernel_call ((DEVICE_TYPE (device.dtypex)), device.device_name, ecode);
	     temp_mode = ""b;
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), temp_mode, ecode);
	     call cleanup_kernel_call (ecode);		/* the above call was just to provoke an audit, so we can discard the error code. */
	end;

	rcse.flags.volume = "0"b;
	if device.volume_name ^= "" then do;		/* then let him know it. */
	     if rcpd.modes.resource_mgmt_enabled then do;
		call setup_kernel_call ((VOLUME_TYPE (device.dtypex)), device.volume_name, ecode);
		if ecode = 0 then do;
		     detailed_operation.search = "1"b;	/* Don't audit this since a denial is unimportant. */
		     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), effmode, ecode);
		     detailed_operation.search = "0"b;
		     if ecode = 0 then do;
			rcse.flags.volume = "1"b;
			rcse.volume_name = device.volume_name;
		     end;
		     else ecode = 0;
		end;
		else ecode = 0;			/* no such volume? ignore the problem, and just hand over the requested device. ycch. */
		call cleanup_kernel_call (ecode);
	     end;
	     else if rcp_match_user_name_ (rcse.group_id, device.group_id) then do;
		rcse.flags.volume = "1"b;
		rcse.volume_name = device.volume_name;
	     end;
	end;

	if ^rcse.flags.volume then
	     rcse.volume_name = "";
	rcse.flags.preload_allowed = ^rcpd.modes.unload_on_detach;
	rcse.flags.not_removable_media = device.flags.not_removable_media;

	device.process_id = rcse.process_id;		/* Save info about assignment. */
	device.group_id = rcse.group_id;
	if device.flags.reservable			/* Can device be reserved? */
	     then
	     device.flags.reserved = system_flag;
	else device.flags.reserved = "0"b;
	if device.state = DELETED			/* Are we assigning a deleted device? */
	then do;					/* Yes. */
	     call admin_gate_$ioi_add_device ((device.device_name), ignored_code);
	     device.flags.delete,			/* Remember to delete when unassigned. */
		device.flags.priv = "1"b;		/* Special assignment for privileged attachment. */
	end;
	device.state_time = clock ();			/* Note when assigned. */
	device.unassign_state = device.state;		/* redundant for DELETED, since flags.delete forces unassignment to delete */
						/* the curious result of this is that if the operator  */
						/* during the .priv attachment it will fail. */
	device.current_authorization = get_authorization_ ();
						/* Save this guy's authorization. */
	device.state = ASSIGNED;			/* Device is now assigned. */

	if device.unassign_state ^= RESERVED then	/* Accounting for reserved devices is done at reservation time. */
	     call ACCOUNT_WAKEUP (device_ptr, RCP_ACCTMSG_assign);

	rcse.state = 2;				/* Tell requesting process assignment complete. */
	rcse.device_off = device_off;			/* Save offset of rcp_data entry. */
	rcse.device_name = device.device_name;		/* Return info about assigned device. */
	rcse.model = device.model;
	do i = 1 to device.num_qualifiers;
	     rcse.qualifiers (i) = device.qualifiers (i);
	end;
	rcse.flags.system = system_flag;		/* Note whether assigned as a system process. */
	rcse.flags.fips = device.flags.fips;		/* pass along fips flag */
	rcse.flags.no_protect = device.flags.no_protect;	/* pass along no_protect flag */
	rcse.flags.opr_int_available = device.flags.opr_int_available;
						/* pass along opr_int_available flag */

/*	Note this assignment in the syserr log.
*/
	call admin_gate_$syserr (LOG, "RCP: Assigned ^a to ^a", device.device_name, device.group_id);

     end ASSIGN_DEVICE;
%page;
TEST_DEVICE:
     procedure;

/*	This procedure is called to test a device.  We will see if it is
   *	appropriate, accessible, and available.  If it is all three we
   *	will add it to a list of such devices.
*/

/* Test free devices and deleted devices */

	if (device.state = FREE) | (device.state = DELETED & rcse.flags.priv) then do;
	     if device.dtypex = CONSOLE_DTYPEX then
		call admin_gate_$console_free (substr (device.device_name, 1, 4), console_free);

/**** The following test is obscure. Note the following:
      if a console is RCP-DELETED, then it is in ocdcm_ unavailable.
      However, ocdcm_ does nothing different for an UNAVAILABLE device
      from an INOP or an I/O device.
      Therefore, checking the console_free flag suffices for consoles. */

	     if (device.dtypex = CONSOLE_DTYPEX & console_free) | (device.dtypex ^= CONSOLE_DTYPEX) then do;
		if device.flags.reservable then	/* Can this device be reserved? */
		     num_free_res = num_free_res + 1;	/* Yes, count free reservable devices. */
		else ;
		available_flag = "1"b;		/* Device is available. */
	     end;
	end;

/*  Test assigned devices */

	else if (device.state = ASSIGNED) then do;
	     if device.process_id = rcse.process_id then	/* Assigned to requesting process? */
		num_assigned = num_assigned + 1;	/* Yes, count number assigned to this process. */
	     if device.flags.reserved then		/* Is device reserved to a system process? */
		num_reserved = num_reserved + 1;	/* Yes, count these too. */
	     available_flag = "0"b;			/* This device is not available. */
	end;

/*  Test reserved devices */

	else if (device.state = RESERVED) then
	     if device.process_id = rcse.process_id then
		available_flag = "1"b;
	     else available_flag = "0"b;

/*  Must be a storage system device - forget it */
	else return;

/*  Make appropriate, accessible, available test */

	match_flag = rcp_match_$match (rcse_ptr, device_ptr);
	if match_flag then				/* Did it match, i.e., is it appropriate? */
	     one_was_appropriate = "1"b;
	else return;				/* No this device is not appropriate. */
	operation = access_operations_$rcp_assign_write;
	if ^rcse.flags.device then
	     detailed_operation.search = "1"b;
	call setup_kernel_call ((DEVICE_TYPE (device.dtypex)), device.device_name, ecode);
	detailed_operation.priv_gate_call = ""b;	/* Device assignment is not a privileged */
						/* gate call, even through rcp_priv_ */
	if ecode = 0 then
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), effmode, ecode);
	if ecode = 0 then
	     accessible_flag = "1"b;
	else do;
	     accessible_flag = "0"b;
	     ecode = 0;
	end;
	call cleanup_kernel_call (ecode);		/* don't zero code until it has been tested */

	if ^accessible_flag then
	     return;

	one_was_accessible = "1"b;

	if ^available_flag then
	     return;

	num_available = num_available + 1;
	if num_available = MAX_AVAILABLE then
	     full = "1"b;				/* available list is now full */
	available_list (num_available) = device_ptr;	/* Put this device in the available list. */
	if device.state = RESERVED then		/* a reserved device */
	     num_resvd = num_resvd + 1;
	return;					/* test passes here */
     end TEST_DEVICE;
%page;
CHECK_LIMITS:
     procedure;

dcl	i		   fixed bin;

/*	This procedure is called to check the limits imposed upon non
   *	system processes.  These limits are:
   *	     1.	Only a certain number of devices of any one type may be assigned
   *		to a process at at one time.
   *	     2.	A certain number of reservable devices of this type
   *		must be free or in use by system processes.
*/
	if system_flag				/* Is this a system process? */
	     then
	     return;				/* Yes, no need to test limits. */

	if num_resvd ^= 0 then
	     return;				/* can always use reserved device */

	if num_assigned >= dtype.max_concurrent		/* Maximum already assigned to this process? */
	then do;					/* Yes. */
	     ecode = error_table_$device_limit_exceeded;
	     return;
	end;

	if num_reserved >= dtype.num_reserved		/* Already using the quota of system drives? */
	     then
	     return;				/* Yes, don't bother the user */

	if num_free_res > (dtype.num_reserved - num_reserved) then
	     return;				/* There are enough free reservable devices. */

	num_avail_nres = 0;				/* Count number that will be available. *. */
	do i = 1 to num_available;			/* Remove reservable devices from selection list. */
	     device_ptr = available_list (i);
	     if ^device.flags.reservable		/* If non reservable keep in list. */
	     then do;
		available_list (num_avail_nres) = device_ptr;
		num_avail_nres = num_avail_nres + 1;
	     end;
	end;
	num_available = num_avail_nres;		/* Now only non reservable devices are available. */
	if num_available = 0			/* Are there any available devices left? */
	then do;					/* No, only reservable devices were available. */
	     ecode = error_table_$resource_unavailable;
	     return;
	end;

     end CHECK_LIMITS;
%page;
ERROR_COUNT:
     procedure;

/*	This procedure is called to update the error count for a device.
*/
	dev_rcse_off = a_device_offset;
	device_ptr = ptr (rcpd_ptr, dev_rcse_off);

	if device.state ^= ASSIGNED then		/* Is device assigned? */
	     ecode = error_table_$resource_unassigned;	/* No, ignore this call. */

	if device.process_id ^= get_process_id_ () then
	     ecode = error_table_$resource_unassigned;	/* Not assigned to this process. */

	if ecode = 0 then do;
	     device.error_count = device.error_count + error_count;
	     a_error_count = device.error_count;
	end;
	return;
     end ERROR_COUNT;
%page;
UNASSIGN:
     procedure;

/*	This procedure is called to unassign a device and/or volume.
   *	The volume and device offsets reference RCPD volume and
   *	and device entries.  The resources associated with these
   *	entries will be unassigned.  Before unassigning any
   *	resource we will verify that it is actually assigned to the
   *	requesting process.  We will note this unassignment in the syserr log.
*/
	if detailed_operation.force then do;
	     call FORCE_UNASSIGN;
	     return;
	end;
	if detailed_operation.process then do;
	     call PROC_UNASSIGN;
	     return;
	end;

	volume_off = a_volume_offset;
	device_off = a_device_offset;

	process_id = get_process_id_ ();		/* Get process ID of calling process. */

	if volume_off ^= "0"b			/* Is there a volume to unassign? */
	then do;					/* Yes. */
	     volume_ptr = ptr (rcpd_ptr, volume_off);
	     if volume.process_id = process_id then	/* Volume is assigned to this process. */
		call UNASSIGN_VOLUME ();
	end;

	if device_off ^= "0"b then do;		/* Is there a device to unassign? */
	     device_ptr = ptr (rcpd_ptr, device_off);	/* Yes, get a pointer to its device entry. */
	     if device.process_id = process_id then do;	/* Is it actually assigned to this process? */
		device.error_count = device.error_count + error_count;
		call UNASSIGN_DEVICE;
		call admin_gate_$syserr (LOG, "RCP: Unassigned ^a from ^a", device.device_name, device.group_id);
		a_error_count = error_count;
	     end;
	end;

     end UNASSIGN;
%page;
FORCE_UNASSIGN:
     procedure;

dcl	i		   fixed bin;

/*	This procedure is called to force the unassignment of a device.
   *	The device does not have to be assigned by the requesting process.
   *	If there is a volume mounted on this device we will unassign it.
*/
	device_name = a_device_name;

	call FIND_DEVICE;				/* Search through all devices for this one. */
	if device_off = "0"b then do;			/* Find it? */
	     ecode = error_table_$resource_unknown;	/* No */
	     return;
	end;

	if device.state = ASSIGNED then do;		/* Is device assigned? */
	     call UNASSIGN_DEVICE;			/* Just forcedly unassign it. */
	     call admin_gate_$syserr (ANNOUNCE, "RCP: Force Unassigned ^a from ^a", device_name, device.group_id);
	end;

	if device.volume_name = " "			/* Is there a volume on this device? */
	     then
	     return;				/* No, we are all done. */

	do i = 1 to rcpd.last_volume;			/* Yes, find this volume. */
	     volume_ptr = addr (rcpd.volume (i));	/* Get pointer to next volume entry. */
	     if volume.volume_name = device.volume_name then do;
						/* We found this volume. */
		call UNASSIGN_VOLUME ();
		return;
	     end;
	end;

     end FORCE_UNASSIGN;
%page;
PROC_UNASSIGN:
     procedure;

dcl	i		   fixed bin;

/*	This procedure is called to forcedly unassign all devices and volumes
   *	currently assigned to the process whose process ID has been provided
   *	by the caller of this routine.
*/

	process_id = a_process_id;

	do i = 1 to rcpd.last_volume;			/* Look at all volume entries. */
	     volume_ptr = addr (rcpd.volume (i));	/* Get pointer to volume entry. */
	     if volume.process_id = process_id		/* Does volume belong to this process? */
	     then do;				/* Yes, unassign it. */
		volume.unassign_state = FREE;
		call UNASSIGN_VOLUME ();
	     end;
	end;

	do i = 1 to rcpd.tot_devices;			/* Look at all devices. */
	     device_ptr = addr (rcpd.device (i));
	     if device.process_id = process_id		/* Does device belong to this process? */
	     then do;				/* Yes, forcedly unassign. */
		device.unassign_state = FREE;
		call UNASSIGN_DEVICE;
		call admin_gate_$syserr (LOG, "RCP: Force Unassigned ^a from ^a", device.device_name, device.group_id)
		     ;
	     end;
	end;

     end PROC_UNASSIGN;
%page;
DELETE_DEVICE:
     procedure;

dcl	local_code	   fixed bin (35);
dcl	local_effmode	   bit (3);

/*	This procedure is called to put a device in the deleted state.
   *	This means that the device cannot be assigned to any process.
   *	If the device is currently assigned will will not delete it now.
   *	We will remember to delete it when it is unassigned.
*/
	device_name = a_device_name;			/* Get name of device to delete. */

	call FIND_DEVICE;				/* Find the device with this name. */
	if device_off = "0"b then do;			/* Did we find it? */
	     ecode = error_table_$resource_unknown;
	     goto DELETE_RETURN;
	end;

	if device.state = STORAGE_SYSTEM then
	     goto DELETE_RETURN;			/* Should not be here, but check for ss drives */
	if device.state = ASSIGNED | device.state = RESERVED
						/* Is device still assigned? */
	then do;					/* Yes, we won't delete it now. */
	     device.flags.delete = "1"b;		/* Remember to delete it when unassigned. */
	     ecode = error_table_$device_deletion_deferred;
	     goto DELETE_RETURN;
	end;

	if device.volume_name ^= "" & device.dtypex = 1 then
	     call rcp_unload_$unload_device (device_ptr, "1"b);
						/* unload volume and forget it was here */

	call admin_gate_$ioi_delete_device (device_name, ecode);
	if ecode ^= 0 then
	     goto DELETE_RETURN;

	device.volume_name = " ";			/* Forget any volume on the deleted device. */
	device.process_id = "0"b;			/* Make sure it doesn't belong to any process. */
	device.state = DELETED;			/* Just change its state. */
	device.state_time = clock ();			/* And remember when. */

	if device.dtypex = CONSOLE_DTYPEX then		/* must inform console DIM of deletion... */
	     call admin_gate_$ocdcm_reconfigure (substr (device_name, 1, 4), MAKE_UNAVAILABLE, ecode);

	call admin_gate_$syserr (ANNOUNCE, "RCP: Deleted device ^a", device_name);
DELETE_RETURN:					/* Let's perform auditing. Call setup_kernel_call to set up */
						/* the resource_info and requestor_info structures although we */
						/* really don't call the kernel for this operation, it has all the */
						/* information so let it do the auditing for us. */
	local_code = 0;
	call setup_kernel_call ((DEVICE_TYPE (device.dtypex)), device.device_name, local_code);
	if local_code = 0 then do;			/* if we didn't find the resource at all ... */
	     detailed_operation.priv_gate_call = "1"b;
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), local_effmode, (ecode));
	end;
	call cleanup_kernel_call (local_code);
	if ecode = 0 then
	     ecode = local_code;
	return;

     end DELETE_DEVICE;





ADD_DEVICE:
     procedure;

/*	This procedure is called to take a device out of the deleted state.
   *	This will only be done if the device is already in the deleted state.
*/

dcl	local_code	   fixed bin (35);
dcl	local_effmode	   bit (3);
dcl	operational	   bit (1) aligned;
dcl	1 tape_name	   unaligned,
	  2 subsystem	   char (4),
	  2 bar		   char (1),
	  2 drive		   pic "99";

	device_name = a_device_name;			/* Get name of device to add. */

	call FIND_DEVICE;				/* Find the device with this name. */
	if device_off = "0"b			/* Did we find it? */
	     then
	     goto ADD_RETURN;

	device.flags.delete = "0"b;			/* Make sure no delete is pending. */

	if device.state ^= DELETED			/* Is device in the deleted state? */
	     then
	     goto ADD_RETURN;			/* No, leave it alone. */

	if (device.dtypex = TAPE_DRIVE_DTYPEX) & (device.qualifiers (1) = 0) then do;
						/* this is a tape drive deleted during initialization */
	     string (tape_name) = substr (device_name, 1, length (string (tape_name)));
	     call rcp_tape_survey_ (tape_name.subsystem, (tape_name.drive), (device.flags.fips), operational,
		device.qualifiers, ecode);
	     if ^operational then do;
		if ecode = 0 then
		     call admin_gate_$syserr (ANNOUNCE, "RCP: ^a is not operational and will not be added.",
			device_name);
		goto ADD_RETURN;
	     end;
	end;

	call admin_gate_$ioi_add_device (device_name, ecode);
	if ecode ^= 0 then
	     goto ADD_RETURN;

	device.state = FREE;			/* Put it into the free state. */
	device.unassign_state = FREE;			/* And keep it there. */
	device.state_time = clock ();			/* Save time device added. */

	if device.dtypex = CONSOLE_DTYPEX then		/* must inform console DIM of deletion... */
	     call admin_gate_$ocdcm_reconfigure (substr (device_name, 1, 4), MAKE_IO_DEVICE, ecode);
	call admin_gate_$syserr (ANNOUNCE, "RCP: Added device ^a", device_name);
ADD_RETURN:					/* Let's perform auditing. Call setup_kernel_call to set up */
						/* the resource_info and requestor_info structures although we */
						/* really don't call the kernel for this operation, it has all */
						/* information to do the auditing so let it do it. */
	local_code = 0;
	call setup_kernel_call ((DEVICE_TYPE (device.dtypex)), device.device_name, local_code);
	if local_code = 0 then do;			/* if we didn't find the resource at all ... */
	     detailed_operation.priv_gate_call = "1"b;
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), local_effmode, (ecode));
	end;
	call cleanup_kernel_call (local_code);
	if ecode = 0 then
	     ecode = local_code;
	return;

     end ADD_DEVICE;
%page;
ACCOUNT_ATTACH:
     procedure;

/*	This procedure is called when an attachment is completed.  The rcp_control_
   *	wakes the accounting process with a datum about the attachment. */

	device_off = a_device_offset;

	device_ptr = ptr (rcpd_ptr, device_off);

	call ACCOUNT_WAKEUP (device_ptr, RCP_ACCTMSG_attach);

	return;

     end ACCOUNT_ATTACH;
%page;
UNASSIGN_DEVICE:
     procedure;

dcl	ignored_code	   fixed bin (35);		/* Ignored error code. */
dcl	i		   fixed bin;
dcl	old_state		   fixed bin;

/*	This procedure is called to put a device in the state it was in
   *	at assignment time.
   *	It will also compute the metering statistics kept for each device.
   *	If the device was supposed to be deleted but was not because it was still
   *	assigned we will delete it now.
*/
	time_assigned = device.state_time;		/* Save time assigned. */

	old_state = device.state;
	if device.flags.delete			/* Are we waiting to delete this device? */
	     & (device.unassign_state = FREE | device.unassign_state = DELETED)
						/* and it won't still be reserved after this unassignment */
	then do;					/* Yes, delete it now. */
	     if ^device.flags.priv & device.volume_name ^= "" & device.dtypex <= 2 then do;
						/* Must unload this loaded device. */
		device.state = FREE;		/* do this now to permit unload */
		call rcp_unload_$unload_device (device_ptr, "1"b);
						/* unload volume and forget it was here */
	     end;
	     call admin_gate_$ioi_delete_device ((device.device_name), ignored_code);
	     device.state = DELETED;			/* Now it is deleted. */
	     device.volume_name = "";
	     if ^device.flags.priv			/* If not assigned while deleted say it is deleted now. */
		then
		call admin_gate_$syserr (ANNOUNCE, "RCP: Deleted device ^a", device.device_name);
	     device.flags.delete,			/* Turn off these flags. */
		device.flags.priv = "0"b;
	end;
	else device.state = device.unassign_state;	/* No, unassign the device. */

	device.unassign_state = FREE;

	if device.state ^= RESERVED then do;		/* Accounting for reserved devices is done at cancel time. */
						/* the only other possibilities are DELETED and FREE */
	     call ACCOUNT_WAKEUP (device_ptr, RCP_ACCTMSG_unassign);
						/* go send wakeup before clearing process_id */
	     device.process_id = "0"b;		/* No longer assigned to this process. */
	     device.reservation_id = 0;
	     device.reserved_by = "";
	end;
	device.state_time = clock ();			/* Time device made free. */

	device.num_assigns = device.num_assigns + 1;
	device.flags.mounting = "0"b;			/* Turn off mount timer for this device. */
	device.flags.attached = "0"b;

	time_assigned = device.state_time - time_assigned;
	device.tot_assign_time = device.tot_assign_time + time_assigned;
	time_assigned = divide (time_assigned, 1000000, 71, 0);
	dtype_ptr = addr (rcpd.dtype (device.dtypex));

	do i = 1 to hbound (dtype.histo_times, 1);	/* Find histogram slot. */
	     if time_assigned < dtype.histo_times (i) then do;
						/* We found the right slot. */
		device.histogram (i) = device.histogram (i) + 1;
		return;
	     end;
	end;					/* Falling through loop => use last slot. */
	device.histogram (hbound (device.histogram, 1)) = device.histogram (hbound (device.histogram, 1)) + 1;

     end UNASSIGN_DEVICE;
%page;
UNASSIGN_VOLUME:
     proc ();

dcl	ignored_code	   fixed bin (35);		/* Ignored error code. */
dcl	old_state		   fixed bin (35);

/*
   This procedure is called to put a volume in the free or reserved
   state.  The choice is made based on the volume's state at the time of
   the last assignment.
*/

	volume.state_time = clock ();			/* record the time */
	old_state = volume.state;
	volume.state = volume.unassign_state;		/* and return the volume to the proper state */
	volume.unassign_state = FREE;			/* reset the unassign state */
	if volume.state = FREE then do;		/* if we are freeing it ... */
	     volume.process_id = "0"b;		/* no process owns it now */
	     volume.reserved_by = "";
	     volume.reservation_id = 0;
	     if old_state = RESERVED then
		call rcp_cancel_resource_ (VOLUME_TYPE (volume.vtypex), (volume.volume_name), ignored_code);
						/* Tell Resource Management that this volume has been turned loose. */
	     if rcpd.unload_on_detach then do;		/* all done */
		volume.volume_name = "";		/* no need to remember the volume_name */
		volume.group_id = "";
	     end;
	end;
	return;

     end UNASSIGN_VOLUME;
%page;
FIND_DEVICE:
     procedure;

dcl	i		   fixed bin;		/*	This procedure is called to find the device entry of the device with
						   *	the specified name.  We will search by device type since tapes and
						   *	disks are the most active types.
						*/
	do i = 1 to rcpd.tot_dtypes;			/* Look at each device type. */
	     dtype_ptr = addr (rcpd.dtype (i));		/* Get pointer to device type entry. */
	     device_off = dtype.first_off;		/* Start with first device type. */
	     do while (device_off ^= "0"b);		/* Look at each device of this type. */
		device_ptr = ptr (rcpd_ptr, device_off);
		if device.device_name = device_name then
		     return;			/* This is the device.  Look no further. */
		device_off = device.next_off;
	     end;
	end;

	device_off = "0"b;				/* Let caller know we didn't find device. */

     end FIND_DEVICE;
%page;
ACCOUNT_WAKEUP:
     procedure (a_devptr, a_action);

/*	This procedure is called to format an accounting message, and send it to the
   *	accounting process.  If the accounting event channel has not been set up, no message is sent.
*/


dcl	a_devptr		   ptr;			/* Pointer to rcp_data entry */
dcl	a_action		   fixed bin;		/* Accounting action */

dcl	wakeup_buf	   fixed bin (71);
dcl	1 auto_rcpamsg	   like rcp_account_msg aligned;

	unspec (auto_rcpamsg) = "0"b;

	auto_rcpamsg.device_user_procid = a_devptr -> device.process_id;
	auto_rcpamsg.rcp_data_relp = rel (a_devptr);
	auto_rcpamsg.devtype = a_devptr -> device.dtypex;
	auto_rcpamsg.action = a_action;

	unspec (wakeup_buf) = unspec (auto_rcpamsg);
	if rcpd.accounting_chan ^= 0 then
	     call hcs_$wakeup (rcpd.accounting_pid, rcpd.accounting_chan, wakeup_buf, (0));

     end ACCOUNT_WAKEUP;
%page;
ss_io_interchange:
     entry (a_device_name, a_add_sw, a_del_sw, a_ecode);

/*	Entry to add and delete disk drives on demand, called from mdx in
   *	the initializer's process, in ring 1. a_add_sw is "1"b if drive is
   *	being given back to RCP.
*/

	device_name = a_device_name;
	add_sw = a_add_sw;
	del_sw = a_del_sw;
	ecode = 0;

	rcpd_ptr = rcp_pointers_$data ();
	rcs_ptr = rcp_pointers_$com_seg ();

	on cleanup
	     begin;
	     call cleanup_kernel_call ((0));
	     call UNLOCK;				/* If trouble unlock rcp_data. */
	end;

	call rcp_lock_$lock (addr (rcpd.lock_info), ecode);
	if ecode ^= 0 then do;
	     a_ecode = ecode;
	     return;
	end;

	call FIND_DEVICE;				/* Attempt to find the device */

	if device_off = "000000"b3 then
	     ecode = error_table_$resource_unknown;
	else if dtype.device_type ^= DEVICE_TYPE (DISK_DRIVE_DTYPEX) then
	     ecode = error_table_$invalid_state;

	if ecode = 0 then
	     if add_sw then
		if device.state = STORAGE_SYSTEM then
		     if del_sw then
			device.state = DELETED;	/* deleted */
		     else device.state = FREE;	/* free */
		else ecode = error_table_$invalid_state;
	     else if device.state = ASSIGNED then
		ecode = error_table_$io_still_assnd;
	     else device.state = STORAGE_SYSTEM;

	if ecode = 0 then do;
	     device.state_time = clock ();
	     device.volume_name = " ";
	     device.process_id = "000000000000"b3;
	     call admin_gate_$syserr (ANNOUNCE, "RCP: ^[Acquired ^a from^;Consigned ^a to^] storage system.", add_sw,
		device_name);
	end;

	a_ecode = ecode;
	call UNLOCK;
	return;
%page;
setup_kernel_call:
     proc (a_resource_type, a_resource_name, a_code);

dcl	(a_resource_type, a_resource_name)
			   char (*) aligned;
dcl	a_code		   fixed bin (35);
dcl	local_code	   fixed bin (35);

dcl	rcprm_registry_util_$grab_transaction_control_file
			   entry (ptr, char (*) aligned, fixed bin (35));
dcl	rcprm_registry_util_$grab_registry
			   entry (ptr, char (*) aligned, char (*) aligned, fixed bin (35));
dcl	rcprm_registry_util_$find_resource_record
			   entry (ptr, char (*) aligned, ptr, fixed bin (35));

	local_code = 0;
	if rcpd.modes.resource_mgmt_enabled then do;
	     res_info.registry_dir = DEFAULT_REGISTRY_DIR;
	     call rcprm_registry_util_$grab_transaction_control_file (trans_iocb_ptr, res_info.registry_dir, local_code)
		;
	     if local_code ^= 0 then
		goto SETUP_RETURN;
	     call rcprm_registry_util_$grab_registry (reg_iocb_ptr, res_info.registry_dir, a_resource_type, local_code);
	     if local_code ^= 0 then
		goto SETUP_RETURN;
	     call rcprm_registry_util_$find_resource_record (reg_iocb_ptr, a_resource_name, record_ptr, local_code);
	     if local_code ^= 0 then do;
		if local_code = error_table_$no_key then
		     local_code = error_table_$resource_unknown;
						/* well defined reason for this. */
		call cleanup_kernel_call ((0));	/* undo the above */
		goto SETUP_RETURN;
	     end;
	     res_info.registry_switch_ptr = reg_iocb_ptr;
	     res_info.registry_record_ptr = record_ptr;
	end;
	else do;
	     res_info.registry_dir = "";
	     res_info.registry_switch_ptr, res_info.registry_record_ptr = null ();
	end;
	if (basic_operation (operation) = access_operations_$rcp_unassign
	     & (detailed_operation.force | detailed_operation.process))
	     | (base_op = access_operations_$rcp_delete_device) | (base_op = access_operations_$rcp_add_device) then
	     detailed_operation.priv_gate_call = "1"b;
	else detailed_operation.priv_gate_call = "0"b;
	res_info.resource_type = a_resource_type;
	res_info.resource_name = a_resource_name;
	if base_op = access_operations_$rcp_add_device | base_op = access_operations_$rcp_delete_device then do;
	     req_info.user_id = get_group_id_ ();
	     req_info.validation_level = 1;
	end;
	else do;
	     req_info.user_id = rcse.group_id;
	     req_info.validation_level = rcse.caller_level;
	end;
	call hcs_$get_authorization (req_info.current_authorization, ""b);

SETUP_RETURN:
	a_code = local_code;
     end setup_kernel_call;
%page;
cleanup_kernel_call:
     proc (a_code);

dcl	a_code		   fixed bin (35);
dcl	local_code	   fixed bin (35);
dcl	rcprm_registry_util_$release_transaction_control_file
			   entry (ptr, fixed bin (35));
dcl	rcprm_registry_util_$release_registry
			   entry (ptr, fixed bin (35));

	local_code = 0;
	if reg_iocb_ptr ^= null () then
	     call rcprm_registry_util_$release_registry (reg_iocb_ptr, local_code);
	if trans_iocb_ptr ^= null () then
	     call rcprm_registry_util_$release_transaction_control_file (trans_iocb_ptr, local_code);

	a_code = local_code;
     end cleanup_kernel_call;

basic_operation:
     proc (oper) returns (bit (36) aligned);

dcl	oper		   bit (36) aligned;
dcl	return_arg	   bit (36) aligned;

	return_arg = oper;
	addr (return_arg) -> encoded_access_op.detailed_operation = 0;
	return (return_arg);

     end basic_operation;
%page;
%include access_mode_values;
%page;
%include rcp_data;
%page;
%include rcp_com_seg;
%page;
%include rcp_account_msg;
%page;
%include rcp_resource_states;
%page;
%include rcp_requestor_info;
%page;
%include rcp_resource_info;
%page;
%include rcp_resource_types;
%page;
%include access_audit_encoded_op;
%include rcp_ops;
%page;
%include opc_reconfig_options;
%page;
%include syserr_constants;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Acquired DEVICE from storage system.

   S:	$info

   T:	$response

   M:	The operator has used the set_drive_usage command to make
   DRIVE an IO drive.

   A:	$ignore


   Message:
   RCP: Added device DEVICE

   S:	$info

   T:	$response

   M:	The operator has added a user I/O disk drive with adddev.

   A:	$ignore


   Message:
   RCP: Assigned DEVICE to PERSON.PROJ.T

   S:	$log

   T:	$run

   M:	DEVICE has been assigned to a user process.

   A:	$ignore


   Message:
   RCP: Consigned DEVICE to storage system.

   S:	$info

   T:	$response

   M:	The operator has used the set_drive_usage command to make DRIVE a storage system drive.

   A:	$ignore


   Message:
   RCP: Deleted device DEVICE

   S:	$info

   T:	$response

   M:	The operator has deleted user I/O disk DRIVE with deldev.

   A:	$ignore


   Message:
   RCP: Force Unassigned DEVICE from PERSON.PROJ.T

   S:	$info

   T:	$run

   M:	The user process PERSON.PROJ.T has terminated,
   and its resources have been freed.
   Or, the operator may have forced the unassignment of DRIVE.

   A:	$ignore


   Message:
   RCP: Unassigned DEVICE from PERSON.PROJ.T

   S:	$log

   T:	$run

   M:	PERSON.PROJ.T has released DRIVE normally.

   A:	$ignore


   Message:
   RCP: DEVICE is not operational and has not been added.

   S:	$info

   T:	$response

   M:	An attempt was made to add a non-operational device with adddev.

   A:	Ready the device and add it again.


   Message:
   rcp_control_: Error surveying DEVICE. MESSAGE

   S:	$info

   T:	$response

   M:	An error occurred while surveying the device.

   A:	$notify


   END MESSAGE DOCUMENTATION */

     end rcp_control_;




		    rcp_copy_.pl1                   11/11/89  1110.3r   11/11/89  0807.0      155808



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_copy_:
     procedure;

/*	This program implements the RCP copy entries.
   *	Created on 12/26/74 by Bill Silver.
   *	Modified on 04/24/78 by Michael R. Jordan to add the attached and loaded bits.
   *	Modified on 12/09/78 by Michael R. Jordan to add support for listing reservations for both the
   *	  system and user entries.
   *	Modified 1/85 by Chris Jones to stop using magic numbers.
   *	Modified 3/85 by Maria Pozzo to add auditing for B2.
   *
   *	This program is called to copy RCP data out of ring 1.
   *	It has the following entry points:
   *	     1.	data   -	rcp_sys_$copy_data  -  Copys privileged info.
   *	     2. 	meters -	rcp_priv_$copy_meters  -  Copy meters.
   *	     3.	list   -	rcp_$copy_list  -  Copy per user info.
*/

dcl	arg_copy_size	   fixed bin (19);		/* (I) Size of caller's copy buffer. */
dcl	arg_ecode		   fixed bin (35);		/* (O) error_table_ code. */
dcl	arg_to_ptr	   ptr;			/* (I) Pointer to caller's work segment. */

dcl	attach_off	   bit (18);		/* Offset of an RLI attachment entry. */
dcl	dassign_off	   bit (18);		/* Offset of an RLI assignment entry. */
dcl	caller_level	   fixed bin;		/* Caller's validation level. */
dcl	copy_size		   fixed bin (19);		/* Size of caller's copy buffer. */
dcl	device_off	   bit (18);		/* Device entry offset in RCPD. */
dcl	devicex		   fixed bin;		/* Device entry index in RDI. */
dcl	ecode		   fixed bin (35);		/* error_table_ code. */
dcl	(i, j, k)		   fixed bin;
dcl	max_size		   fixed bin (19);		/* Max seg size of caller's work segment. */
dcl	meter_time	   fixed bin (71);		/* Time used to base meters on. */
dcl	num_attach	   fixed bin;		/* Number of attachment entries. */
dcl	num_dassign	   fixed bin;		/* Number of assignment entries. */
dcl	num_lv		   fixed bin;		/* Number of lv entries. */
dcl	operation		   bit (36) aligned;	/* RCP operation */
dcl	operation_ptr	   ptr;
dcl	rcse_off		   bit (18);		/* Offset of an RCS entry. */
dcl	this_process	   bit (36);		/* Process id for the calling process. */
dcl	to_ptr		   ptr;			/* Pointer to caller's work segment. */
dcl	total_size	   fixed bin;		/* Total size of an info structure. */
dcl	who_am_i		   char (32);		/* Identifies the caller. */

dcl	1 en_access_op	   like encoded_access_op aligned based (operation_ptr);
dcl	(addr, fixed, hbound, ptr, rel, size)
			   builtin;

dcl	cleanup		   condition;

dcl	(
	error_table_$bad_arg,
	error_table_$item_too_big,
	error_table_$unimplemented_version
	)		   fixed bin (35) external;

dcl	access_operations_$rcp_copy_info
			   bit (36) aligned external;

dcl	access_audit_r1_$log_obj_ptr
			   entry options (variable);
dcl	clock_		   entry returns (fixed bin (71));
dcl	cu_$level_get	   entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	get_process_id_	   entry () returns (bit (36));
dcl	get_ring_		   entry returns (fixed bin (3));
dcl	get_group_id_	   entry () returns (char (32));
dcl	get_process_authorization_
			   entry () returns (bit (72) aligned);
dcl	hcs_$get_max_length_seg
			   entry (ptr, fixed bin (19), fixed bin (35));
dcl	rcp_rcse_$info	   entry (bit (18), fixed bin, bit (18), fixed bin);
dcl	rcp_pointers_$data	   entry returns (ptr);
dcl	rcp_pointers_$com_seg  entry returns (ptr);
dcl	rcp_lv_$copy	   entry (ptr);
dcl	rcp_lv_$number	   entry (fixed bin);

dcl	DEFAULT_REGISTRY_DIR   char (64) static internal options (constant) init (">sc1>rcp");

data:
     entry (arg_to_ptr, arg_copy_size, arg_ecode);

/*	This entry is called to copy privileged information from rcp_data.
   *	It is used by privileged commands that want to list data about all
   *	of the devices controlled by RCP.
*/
	who_am_i = "rcp_copy_$data";
	call SETUP;				/* Set up and validate arguments. */
	on cleanup call CLEANUP;

	rcpd_ptr = rcp_pointers_$data ();
	rdi_ptr = to_ptr;				/* Return info in RDI structure. */

	if ecode ^= 0 then
	     goto DATA_RETURN;

	if rdi.head.version_num ^= rdi_version_3	/* Are we using the same version as the caller. */
	then do;					/* No. */
	     ecode = error_table_$unimplemented_version;
	     goto DATA_RETURN;
	end;

	if size (rdi_header) > copy_size		/* Is there room for at least the header? */
	then do;					/* No, no room for even this. */
	     ecode = error_table_$item_too_big;
	     goto DATA_RETURN;
	end;

	rdi.head.tot_ddtypes = rcpd.tot_dtypes;		/* Fill in header info. */
	rdi.head.tot_ddevices = rcpd.tot_devices;
	rdi.head.tot_dvolumes = rcpd.last_volume;

	total_size = fixed (rel (addr (rdi.end)), 19) - fixed (rel (rdi_ptr), 19);
	if total_size > copy_size			/* Is there room for the whole structure? */
	then do;					/* No. */
	     ecode = error_table_$item_too_big;
	     goto DATA_RETURN;
	end;

	devicex = 1;				/* Initialize device index. */

	do i = 1 to rcpd.tot_dtypes;			/* Process each device type. */
	     dtype_ptr = addr (rcpd.dtype (i));
	     ddtype_ptr = addr (rdi.ddtypes (i));
	     ddtype.device_type = dtype.device_type;
	     ddtype.max_concurrent = dtype.max_concurrent;
	     ddtype.num_reserved = dtype.num_reserved;
	     ddtype.num_devices = dtype.num_devices;
	     devicex = devicex;
	     ddtype.first_devicex = devicex;		/* Save index of first device of this type. */
	     device_off = dtype.first_off;		/* Get RCPD offset of 1st device of type. */
	     do while (device_off ^= "0"b);		/* Process each device of this type. */
		device_ptr = ptr (rcpd_ptr, device_off);
		ddevice_ptr = addr (rdi.ddevices (devicex));
		ddevice.device_name = device.device_name;
		ddevice.volume_name = device.volume_name;
		ddevice.dtypex = device.dtypex;
		ddevice.model = device.model;
		ddevice.num_qualifiers = device.num_qualifiers;
		do j = 1 to hbound (ddevice.qualifiers, 1);
		     ddevice.qualifiers (j) = device.qualifiers (j);
		end;
		ddevice.state_time = device.state_time;
		ddevice.state = device.state;
		ddevice.iom_num = device.iom_num;
		ddevice.chan_num = device.chan_num;
		ddevice.num_channels = device.num_channels;
		ddevice.flags.reservable = device.flags.reservable;
		ddevice.flags.reserved = device.flags.reserved;
		ddevice.flags.mounting = device.flags.mounting;
		ddevice.flags.writing = device.flags.writing;
		ddevice.flags.attached = device.flags.attached;
		ddevice.flags.loaded = (device.volume_name ^= "") & (^rcpd.modes.unload_on_detach);
		ddevice.group_id = device.group_id;
		ddevice.reservation_id = device.reservation_id;
		ddevice.reserved_by = device.reserved_by;
		device_off = device.next_off;		/* Get offset of next device of this type. */
		devicex = devicex + 1;		/* Increment RDI device index. */
	     end;
	end;

	do i = 1 to rcpd.last_volume;
	     volume_ptr = addr (rcpd.volume (i));
	     dvolume_ptr = addr (rdi.dvolumes (i));
	     dvolume = volume;
	end;

DATA_RETURN:
	call audit (ecode);
	call CLEANUP;
	arg_ecode = ecode;
	return;

meters:
     entry (arg_to_ptr, arg_copy_size, arg_ecode);

/*	This entry is called to copy all meter data from RCS and RCPD.
   *	We will copy only the lock meters from RCS.   Then from RCPD
   *	we will copy all of the lock data, the complete entry for each
   *	device type, and all non security data from each device entry.
   *	With this information the caller can calculate meter data but
   *	cannot determine the state of any device.
*/
	who_am_i = "rcp_copy_$meters";
	call SETUP;				/* Set up arguments. */
	rcpd_ptr = rcp_pointers_$data ();
	rcs_ptr = rcp_pointers_$com_seg ();
	on cleanup call CLEANUP;

	if ecode ^= 0 then
	     goto METERS_RETURN;

	rmi_ptr = to_ptr;				/* Return info in RMI strcuture. */

	if rmi.head.version_num ^= 1			/* Are we using same version as caller? */
	then do;					/* No. */
	     ecode = error_table_$unimplemented_version;
	     goto METERS_RETURN;
	end;

	if size (rmi_header) > copy_size		/* Is there room for RMI header? */
	then do;					/* No, no room for even that. */
	     ecode = error_table_$item_too_big;
	     goto METERS_RETURN;
	end;

	meter_time = clock_ ();			/* Use same time for all devices. */
	rmi.head.tot_mdtypes = rcpd.tot_dtypes;		/* Get totals from RCPD. */
	rmi.head.tot_mdevices = rcpd.tot_devices;

	total_size = fixed (rel (addr (rmi.end)), 19) - fixed (rel (rmi_ptr), 19);
	if total_size > copy_size			/* Is there room for all of RMI? */
	then do;					/* No. */
	     ecode = error_table_$item_too_big;
	     goto METERS_RETURN;
	end;

	rmi.rcs_lock_info = rcs.lock_info;		/* Copy lock data. */
	rmi.rcpd_lock_info = rcpd.lock_info;

	do i = 1 to rcpd.tot_dtypes;			/* Copy info for each device type. */
	     dtype_ptr = addr (rcpd.dtype (i));
	     mdtype_ptr = addr (rmi.mdtypes (i));
	     mdtype.device_type = dtype.device_type;
	     mdtype.num_devices = dtype.num_devices;
	     do j = 1 to hbound (mdtype.histo_times, 1);
		mdtype.histo_times (j) = dtype.histo_times (j);
	     end;
	end;

	do i = 1 to rcpd.tot_devices;			/* Copy info for each device. */
	     device_ptr = addr (rcpd.device (i));
	     mdevice_ptr = addr (rmi.mdevices (i));
	     mdevice.device_name = device.device_name;
	     mdevice.dtypex = device.dtypex;
	     mdevice.error_count = device.error_count;
	     mdevice.num_assigns = device.num_assigns;
	     mdevice.tot_assign_time = device.tot_assign_time;
	     do j = 1 to hbound (mdevice.histogram, 1);
		mdevice.histogram (j) = device.histogram (j);
	     end;
	     if device.state = ASSIGNED		/* If device now assigned tell how long. */
		then
		mdevice.time_assigned = meter_time - device.state_time;
	     else mdevice.time_assigned = 0;
	end;

METERS_RETURN:
	call audit (ecode);
	call CLEANUP;
	arg_ecode = ecode;
	return;

list:
     entry (arg_to_ptr, arg_copy_size, arg_ecode);

/*	This entry is called to return RCS information about all attachments
   *	and assignments of the calling process.
*/
	who_am_i = "rcp_copy_$list";
	call SETUP;				/* Set up arguments. */
	rcpd_ptr = rcp_pointers_$data ();
	rcs_ptr = rcp_pointers_$com_seg ();
	on cleanup call CLEANUP;

	if ecode ^= 0 then
	     goto LIST_RETURN;

	rli_ptr = to_ptr;
	this_process = get_process_id_ ();

	if (rli.head.version_num ^= rli_version_4)	/* Are we and caller using the same RLI structure? */
	then do;					/* No. */
	     ecode = error_table_$unimplemented_version;
	     goto LIST_RETURN;
	end;

	if size (rli_header) > copy_size		/* Is there room for RLI header? */
	then do;					/* No, no room for even that. */
	     ecode = error_table_$item_too_big;
	     goto LIST_RETURN;
	end;

/* Get per process RCS information. */
	call rcp_rcse_$info (attach_off, num_attach, dassign_off, num_dassign);
	call rcp_lv_$number (num_lv);			/* get number of lvs. */

	rli.head.num_dassign = num_dassign;		/* Fill in RLI header info. */
	rli.head.num_attach = num_attach;
	rli.head.num_lv = num_lv;

	rli.head.num_device_resv = 0;
	do i = 1 to rcpd.tot_devices;			/* loop through all devices */
	     device_ptr = addr (rcpd.device (i));
	     if (device.reservation_id ^= 0) & (device.process_id = this_process) then
		rli.head.num_device_resv = rli.head.num_device_resv + 1;
	end;

	rli.head.num_vol_resv = 0;
	do i = 1 to rcpd.last_volume;			/* and then loop through all volumes */
	     volume_ptr = addr (rcpd.volume (i));
	     if (volume.reservation_id ^= 0) & (volume.process_id = this_process) then
		rli.head.num_vol_resv = rli.head.num_vol_resv + 1;
	end;

	total_size = fixed (rel (addr (rli.end)), 19) - fixed (rel (rli_ptr), 19);
	if total_size > copy_size			/* Is there room for all info? */
	then do;					/* No. */
	     ecode = error_table_$item_too_big;
	     goto LIST_RETURN;
	end;

	rcse_off = dassign_off;			/* Process all assignment RCS entries. */
	num_dassign = 0;
	do while (rcse_off ^= "0"b);			/* We will go through process assignment list. */
	     num_dassign = num_dassign + 1;		/* Index of current assignment entry. */
	     dassign_ptr = addr (rli.dassigns (num_dassign));
	     rcse_ptr = ptr (rcs_ptr, rcse_off);	/* Pointer fo RCS entry we get info from. */
	     rcse_off = rcse.user_off;		/* Offset of next RCS entry in this list. */
	     dassign.device_name = rcse.device_name;	/* Copy all fields needed for assignment entry. */
	     dassign.dtypex = rcse.dtypex;
	     dassign.model = rcse.model;
	     do i = 1 to rcse.num_qualifiers;
		dassign.qualifiers (i) = rcse.qualifiers (i);
	     end;
	     dassign.state_time = rcse.state_time;
	     dassign.state = rcse.state;
	     dassign.level = rcse.caller_level;
	     dassign.disposition = rcse.disposition;
	     if rcse.rcse_off = "0"b then
		dassign.flags.attached = "0"b;
	     else dassign.flags.attached = "1"b;
	     dassign.rcp_id = rcse.rcp_id;
	     dassign.usage_time, dassign.wait_time = 0;
	end;

	rcse_off = attach_off;			/* Process all attachment entries. */
	num_attach = 0;
	do while (rcse_off ^= "0"b);			/* Go through process attachment list. */
	     num_attach = num_attach + 1;		/* Index of current attachment entry. */
	     attach_ptr = addr (rli.attaches (num_attach));
	     rcse_ptr = ptr (rcs_ptr, rcse_off);	/* Pointer to RCS entry we get info from. */
	     rcse_off = rcse.user_off;		/* Offset of next RCS entry in this list. */
	     attach.device_name = rcse.device_name;	/* Copy all fields needed for attachment entry. */
	     attach.volume_name = rcse.volume_name;
	     attach.dtypex = rcse.dtypex;
	     attach.state_time = rcse.state_time;
	     attach.state = rcse.state;
	     attach.level = rcse.caller_level;
	     attach.flags.priv = rcse.flags.priv;
	     attach.flags.writing = rcse.flags.writing;
	     attach.rcp_id = rcse.rcp_id;
	     attach.workspace_max = rcse.workspace_max;
	     attach.timeout_max = rcse.timeout_max;
	     attach.ioi_index = rcse.ioi_index;
	     attach.usage_time, attach.wait_time = 0;
	end;

	if num_lv ^= 0				/* Are there any lvs to list? */
	     then
	     call rcp_lv_$copy (rli_ptr);		/* Yes, copy list of lv info. */

	k = 0;
	do i = 1 to rcpd.tot_devices;			/* loop through all devices */
	     device_ptr = addr (rcpd.device (i));
	     if (device.reservation_id ^= 0) & (device.process_id = this_process) then do;
		k = k + 1;
		device_resv_ptr = addr (rli.device_resvs (k));
		device_resv.reservation_id = device.reservation_id;
		device_resv.reserved_by = device.reserved_by;
		device_resv.device_name = device.device_name;
	     end;
	end;

	k = 0;
	do i = 1 to rcpd.last_volume;			/* and then loop through all volumes */
	     volume_ptr = addr (rcpd.volume (i));
	     if (volume.reservation_id ^= 0) & (volume.process_id = this_process) then do;
		k = k + 1;
		vol_resv_ptr = addr (rli.vol_resvs (k));
		vol_resv.reservation_id = volume.reservation_id;
		vol_resv.reserved_by = volume.reserved_by;
		vol_resv.volume_name = volume.volume_name;
	     end;
	end;

LIST_RETURN:
	call CLEANUP;				/* We don't bother to audit 'cause this is non-privileged */
	arg_ecode = ecode;
	return;

SETUP:
     procedure;

/*	This procedure is called to set up and validate the caller's
   *	segment pointer.  We must be sure that we don't copy past the
   *	end of his segment.
*/
	call cu_$level_get (caller_level);		/* Save caller's validation level. */
	call cu_$level_set (get_ring_ ());		/* Set validation level to RCP level. */

	to_ptr = arg_to_ptr;			/* Copy arguments. */
	copy_size = arg_copy_size;
	operation = access_operations_$rcp_copy_info;
	operation_ptr = addr (operation);
	en_access_op.detailed_operation = 0;
	ops_ptr = addr (en_access_op.detailed_operation);
/**** the one non-priv entry (list) isn't audited, so always set this flag ****/
	detailed_operation.priv_gate_call = "1"b;
	call hcs_$get_max_length_seg (to_ptr, max_size, ecode);
	if ecode ^= 0 then
	     return;

	if (fixed (rel (to_ptr), 19) + copy_size) > max_size then
	     ecode = error_table_$bad_arg;

     end SETUP;

audit:
     proc (code);

dcl	code		   fixed bin (35) parameter;

dcl	1 auto_event_flags	   like audit_event_flags aligned;

	unspec (auto_event_flags) = ""b;
	auto_event_flags.grant = (code = 0);
	auto_event_flags.priv_op = "1"b;

	call access_audit_r1_$log_obj_ptr (who_am_i, caller_level, unspec (auto_event_flags), operation, rcpd_ptr, code,
	     null (), 0);

     end audit;

CLEANUP:
     proc;

	call cu_$level_set (caller_level);

     end CLEANUP;

%include access_mode_values;
%page;
%include access_audit_eventflags;
%page;
%include access_audit_encoded_op;
%page;
%include rcp_data;
%page;
%include rcp_com_seg;
%page;
%include rcp_data_info;
%page;
%include rcp_meter_info;
%page;
%include rcp_list_info;
%page;
%include rcp_ops;
%page;
%include rcp_requestor_info;
%page;
%include rcp_resource_info;
%page;
%include rcp_resource_states;
%page;
%include rcp_resource_types;

     end rcp_copy_;




		    rcp_detach_.pl1                 11/11/89  1110.3rew 11/11/89  0805.9      115614



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



/****^  HISTORY COMMENTS:
  1) change(85-09-11,Fawcett), approve(85-09-11,MCR6979),
     audit(85-12-02,CLJones), install(86-03-21,MR12.0-1033):
     Add MCA support
                                                   END HISTORY COMMENTS */

rcp_detach_:
     procedure;

/*	This program implements the rcp_$detach entry point.
   *	It is also an internal interface of RCP.
   *	Created on 12/11/74 by Bill Silver.
   *	Modified 1/79 by R.J.C. Kissel to fix the mount timer bug.
   *	Modified 830818 to delete admin_gate_$give_console... -E. A. Ranzenbach
   *	Modified 841005 to interface to rcp_control_ instead of rcp_initializer_ ... -M. M. Pozzo
   *      Modified 1985-04-03 by Paul Farley & RAF to add support for MCA as device_type (8).
   *
   *	This program contains the following entry points:
   *	     1.	detach  -  Detach and possible unassign a device.
   *	     2.	force_detach  -  Detach a device that is being forcedly unassigned.
*/

/*		ARGUMENT  DATA		*/

	dcl     arg_comment		 char (*);	/* (I) Caller's comment. */
	dcl     arg_disposition	 bit (*);		/* (I) ON => retain,  OFF => default. */
	dcl     arg_ecode		 fixed bin (35);	/* (O) error_table_ code. */
	dcl     arg_error_count	 fixed bin;	/* (I) User ring error count for attachment. */
	dcl     arg_rcp_id		 bit (36) aligned;	/* (I) ID used to identify RCS entry. */
	dcl     arg_rcse_ptr	 ptr;		/* (I) Pointer to attachment RCSE. */


/*		AUTOMATIC  DATA		*/

	dcl     disposition		 bit (1);		/* Assignment disposition. */
	dcl     device_off		 bit (18) aligned;
						/* Offset of RCSE device entry. */
	dcl     force_detach_entry	 bit (1);		/* set if force_detach entry */
	dcl     volume_off		 bit (18) aligned;
						/* Offset of RCSE volume entry. */
	dcl     rcp_id		 bit (36) aligned;	/* Used to copy rcp_id argument. */
	dcl     process_id		 bit (36) aligned;
						/* Process id requesting operation by RCP */

	dcl     device_name		 char (32);	/* Device name for rcp_control_ */
	dcl     operation		 bit (36) aligned;	/* Operation being requested of rcp_control_ */

	dcl     arcse_ptr		 ptr;		/* Pointer to assignment RCS entry. */
	dcl     caller_level	 fixed bin;	/* Caller's validation level. */
	dcl     dcode		 fixed bin (35);	/* A dummy error_table code. */
	dcl     ecode		 fixed bin (35);	/* error_table_ code. */
	dcl     error_count		 fixed bin (17);	/* Number of errors during attachment. */
	dcl     ioi_index		 fixed bin;	/* Used in final call to IOI. */


/*		BASED  DATA		*/

	dcl     1 arcse		 based (arcse_ptr) like rcse aligned;
						/* Used to reference assignment RCS entry. */


/*		EXTERNAL ENTRIES CALLED	*/

	dcl     cleanup		 condition;	/* Used to set up cleanup handler. */

	dcl     (addr, ptr)		 builtin;

	dcl     error_table_$bad_arg	 fixed bin (35) external;
	dcl     error_table_$force_unassign
				 fixed bin (35) external;

	dcl     access_operations_$rcp_error_count bit (36) aligned ext static;
	dcl     access_operations_$rcp_unassign bit (36) aligned ext static;

	dcl     admin_gate_$ioi_detach entry (fixed bin, fixed bin (35));
	dcl     admin_gate_$syserr	 entry options (variable);
	dcl     cu_$level_get	 entry (fixed bin);
	dcl     cu_$level_set	 entry (fixed bin);
	dcl     get_ring_		 entry returns (fixed bin);
	dcl     mca_attach_$finish_detach entry (fixed bin, bit (1), fixed bin (35));
	dcl     rcp_comment_	 entry (ptr);
	dcl     rcp_control_	 entry (bit (36) aligned, bit (18) aligned, bit (18) aligned, char (*), fixed bin (17),
				 bit (36) aligned, fixed bin (35));
	dcl     rcp_rcse_$free	 entry (ptr, fixed bin (35));
	dcl     rcp_validate_	 entry (bit (36) aligned, fixed bin, ptr, fixed bin (35));
	dcl     rcp_pointers_$data	 entry () returns (ptr);
	dcl     rcp_mount_timer_$reset entry (bit (18) aligned, fixed bin (35));
						/*						*/
%include rcp_data;
%include rcp_com_seg;

detach:
     entry (arg_rcp_id, arg_disposition, arg_error_count, arg_comment, arg_ecode);

/*	This entry implements the rcp_$detach entry point.  It is also called by
   *	RCP programs.  This entry point will detach the device associated with the
   *	specified RCSE entry.  Depending upon the disposition specified in the
   *	call and the disposition specified in the associated assignment RCSE we
   *	will also unassign the device.  In all cases where there is a volume
   *	attached on this drive we will unassign the volume.
*/

	call SETUP;
	force_detach_entry = "0"b;
	call cu_$level_get (caller_level);		/* Get caller's validation level. */
	on cleanup
	     begin;				/* Cleanup if any trouble. */
		call cu_$level_set (caller_level);	/* Reset validation level to caller level. */
	     end;
	call cu_$level_set (get_ring_ ());		/* Set validation level to RCP level. */

	rcp_id = arg_rcp_id;			/* Copy arguments. */
	disposition = arg_disposition;
	error_count = arg_error_count;

	call rcp_validate_ (rcp_id, caller_level, rcse_ptr, ecode);
	if ecode ^= 0				/* Is rcp_id OK? */
	then
	     if ecode = error_table_$force_unassign then
		;
	     else goto RETURN;			/* No. */

	if rcse.kind ^= 1				/* Is this an attachment entry? */
	then do;					/* No. */
		ecode = error_table_$bad_arg;
		goto RETURN;
	     end;

	if rcse.ioi_index ^= 0			/* Is device attached to IOI? */
	then do;					/* Yes, detach it. */
		call DETACH;			/* Detach and tell operator. */
		call admin_gate_$syserr (0, "RCP: Detached ^a from ^a", rcse.device_name, rcse.group_id);

		call rcp_mount_timer_$reset (rcse.device_off, dcode);
						/* Make sure and stop all check mount messages, ignore dcode. */

		if error_count > 0			/* Report any errors. */
		then
		     if rcse.volume_name = "" then
			call admin_gate_$syserr (0, "RCP: Errors (^a) = ^d", rcse.device_name, error_count);
		     else call admin_gate_$syserr (0, "RCP: Errors (^a, volume ^a) = ^d", rcse.device_name,
			     rcse.volume_name, error_count);
	     end;

	rcse.caller_comment = arg_comment;		/* Get comment argument. */
	call rcp_comment_ (rcse_ptr);			/* Type caller's comment. */

	arcse_ptr = ptr (rcse_ptr, rcse.rcse_off);	/* Get pointer to assignment RCS entry. */
	if ^disposition				/* Should we use default disposition? */
	then
	     disposition = arcse.disposition;		/* Yes, get it from assignment entry. */

	device_off,				/* No device or volume specified yet. */
	     volume_off = "0"b;

	if error_count > 0				/* Are there any errors to report? */
	then do;					/* Yes, for now just update error count. */
		operation = access_operations_$rcp_error_count;
		device_off = arcse.device_off;
	     end;

	if ^disposition				/* Should we unassign the device? */
	then do;					/* Yes, rcp_initializer_ will do it. */
		operation = access_operations_$rcp_unassign;
		device_off = arcse.device_off;	/* Get RCPD offset of device. */
		call rcp_rcse_$free (arcse_ptr, dcode);
		if ecode = 0			/* If no previous error use this error code. */
		then
		     ecode = dcode;
	     end;
	else do;
		arcse.rcse_off = "0"b;		/* No, just show that device no longer attached. */
		device_off = "0"b;			/* Don't unassign this device! */
	     end;

	if rcse.flags.volume			/* Is there a volume to unassign? */
	then do;					/* Yes, rcp_initializer_ will do it. */
		operation = access_operations_$rcp_unassign;
		volume_off = rcse.volume_off;		/* Get RCPD offset of volume. */
	     end;

	call rcp_rcse_$free (rcse_ptr, dcode);		/* Always free attachment entry. */
	if ecode = 0 then
	     ecode = dcode;

	if operation ^= ""b				/* Is there any reason to call rcp_control_? */
	then do;					/* Yes, something for it to do. */
		call rcp_control_ (operation, volume_off, device_off, device_name, error_count, process_id, ecode);
	     end;

RETURN:
	arg_ecode = ecode;
	call cu_$level_set (caller_level);
	return;					/*						*/
force_detach:
     entry (arg_rcse_ptr);

/*	This entry point is an internal interface of RCP.  It is called to
   *	detach a device that is being forcedly unassigned.  Freeing the
   *	attachment RCSE and the unassignment of the device and any volume
   *	mounted on it must be done by the caller.
*/

	call SETUP;
	force_detach_entry = "1"b;
	rcse_ptr = arg_rcse_ptr;			/* Get pointer to attachment RCSE. */

	if rcse.ioi_index = 0			/* Is device actually attached via IOI? */
	then
	     return;				/* No, we don't have to do anything. */

	call DETACH;				/* Now go and detach the device. */

/* Tell operator about force detachment. */
	call admin_gate_$syserr (0, "RCP: Force Detached ^a from ^a", rcse.device_name, rcse.group_id);
	return;





SETUP:
     procedure;

	device_off = ""b;
	volume_off = ""b;
	process_id = ""b;
	device_name = "";
	operation = ""b;
	error_count = 0;

     end SETUP;


DETACH:
     procedure;

/*	This procedure is called to perform the actual device detachment.
   *	What we have to do depends upon the device type.
*/
	ioi_index = rcse.ioi_index;			/* Save IOI index. */
	rcse.ioi_index = 0;				/* Make sure IOI never called again by RCP. */
	goto DTYPE (rcse.dtypex);			/* Process according to device type. */

DTYPE (1):					/* TAPE */
	call admin_gate_$ioi_detach (ioi_index, ecode);
	if rcp_pointers_$data () -> rcpd.modes.unload_on_detach then
	     call UNLOAD_DEVICE ();
	return;

DTYPE (2):					/* DISK */
	call admin_gate_$ioi_detach (ioi_index, ecode);
	call UNLOAD_DEVICE ();
	return;

DTYPE (8):					/* MCA */
	call mca_attach_$finish_detach (ioi_index, force_detach_entry, ecode);
DTYPE (3):					/* CONSOLE */
DTYPE (4):					/* PRINTER */
DTYPE (5):					/* PUNCH */
DTYPE (6):					/* READER */
DTYPE (7):					/* SPECIAL */
	call admin_gate_$ioi_detach (ioi_index, ecode);

     end DETACH;

/*

   This internal procedure gets the device_ptr for the device being detached
   and unloades that device by calling rcp_unload_.  This entry is
   normally called with rcp_data locked, but, in this case, the data base
   does not need to be locked.  This is due to the fact that no one can be
   using this device entry except this user until rcp_initializer_ resets
   its state.

*/


UNLOAD_DEVICE:
     proc ();


	dcl     rcp_pointers_$data	 entry () returns (ptr);
	dcl     rcp_unload_$unload_device
				 entry (ptr, bit (1));


	if rcse.rcse_off = "0"b then
	     return;				/* Cannot get to needed rcse. */
	arcse_ptr = ptr (rcse_ptr, rcse.rcse_off);	/* Get ptr to device rcse. */
	if arcse.device_off = "0"b then
	     return;				/* Cannot get to device entry. */
	device_ptr = ptr (rcp_pointers_$data (), rcse.device_off);
	device.flags.attached = "0"b;			/* Mark it as _n_o_t attached. */
	call rcp_unload_$unload_device (device_ptr, "0"b);/* Unload the device. */
	return;


     end UNLOAD_DEVICE;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Detached DEVICE from PERSON.PROJ.T

   S:	$info

   T:	$run

   M:	The user of DEVICE has detached it.

   A:	If DEVICE is a disk drive, demount the volume on it and store it in the library.


   Message:
   RCP: Force Detached DEVICE from PERSON.PROJ.T

   S:	$info

   T:	$run

   M:	The user PERSON.PROJ.T has terminated abnormally.
   This may be due to an automatic logout or a process termination.

   A:	If DEVICE is a disk drive, demount the volume on it and store it in the library.


   Message:
   RCP: Errors (DEVICE) = NN

   S:	$info

   T:	$run

   M:	When DEVICE was detached, its error counter was nonzero.
   This may be due to a problem with DEVICE or with the user program.

   A:	$ignore


   Message:
   RCP: Errors (DEVICE, volume VOL) = NN

   S:	$info

   T:	$run

   M:	When DEVICE was detached, its error counter was nonzero.
   The errors may be due to a problem with DEVICE,
   with the volume VOLUME,
   or with the user program.

   A:	$ignore


   Message:
   RCP: Unloading volume VOLUME from device DEVICE

   S:	$info

   T:	$run

   M:	The specified VOLUME is being demounted by RCP.

   A:	Return the specified VOLUME to the library.


   Message:
   RCP: Manually unload volume VOLUME from device DEVICE

   S:	$beep

   T:	$run

   M:	RCP could not unload the specified volume from the device on which it was loaded.

   A:	Manually unload the volume from the device and return the volume to the library for storage.


   END MESSAGE DOCUMENTATION */

     end rcp_detach_;




		    rcp_detach_lv_.pl1              11/11/89  1110.3rew 11/11/89  0806.7       43812



/****^  ***********************************************************
        *                                                         *
        * 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(85-07-10,EJSharpe), approve(86-02-20,MCR7304),
     audit(86-03-27,CLJones), install(86-04-23,MR12.0-1044):
     added security auditing
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_detach_lv_:
     procedure (arg_rcp_id, arg_ecode);

/*	This procedure implements the rcp_$detach_lv entry point.
   *	Created on 04/08/76 by Bill Silver.
   *	Modified for lv_request_ 09/16/76 by B. Greenberg.
   *	Modified for B2 security cleanup, December 1984 by Chris Jones.
*/

/*
   *	This program is called to detach one logical volume.
   *	We will check to see if this lv is already attached for this process.
   *	If so, we will detach it.  Then we will remove it from the
   *	per-process list of attached logical volumes.
*/

dcl	arg_rcp_id	   bit (36) aligned;	/* (I) ID of this attachment. */
dcl	arg_ecode		   fixed bin (35);		/* (O) error_table_ code. */

dcl	1 auto_event_flags	   aligned like audit_event_flags;
dcl	caller_level	   fixed bin;		/* Validation level of caller. */
dcl	ecode		   fixed bin (35);		/* error_table_code. */
dcl	ignore_mode	   bit (36) aligned;
dcl	ignore_pubbit	   bit (1) aligned;
dcl	lv_access_range	   (2) bit (72) aligned;	/* range of access to LV */
dcl	lvid		   bit (36) aligned;	/* ID of logical volume. */
dcl	rcp_id		   bit (36) aligned;	/* RCP ID of this attach. */
dcl	volume_name_str	   char (64);		/* passed to access_audit_ */

dcl	access_audit_r1_$log_obj_class_range
			   entry options (variable);
dcl	admin_gate_$detach_lv  entry (bit (36) aligned, fixed bin (35));
dcl	cu_$level_get	   entry entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	get_ring_		   entry () returns (fixed bin (3));
dcl	rcp_lv_$check	   entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (35));
dcl	rcp_lv_$del_lv	   entry (bit (36) aligned, fixed bin (35));
dcl	volume_registration_mgr_$get_access_for_attach
			   entry (char (*), fixed bin (3), bit (36) aligned, bit (1) aligned, (2) bit (72) aligned,
			   fixed bin (35));
dcl	volume_registration_mgr_$find_lvname
			   entry (bit (36), char (*), fixed bin (35));

dcl	access_operations_$detach_lv
			   bit (36) aligned external;
dcl	error_table_$logical_volume_not_connected
			   fixed bin (35) external;
dcl	sys_info$access_class_ceiling
			   bit (72) aligned external;

dcl	cleanup		   condition;

dcl	null		   builtin;
dcl	string		   builtin;

/*	Begin rcp_detach_lv_.
*/

	call cu_$level_get (caller_level);		/* Save caller's validation level. */

	on cleanup call cu_$level_set (caller_level);

	call cu_$level_set (get_ring_ ());		/* Set validation level to RCP level. */

	rcp_id = arg_rcp_id;			/* Copy argument. */

	call rcp_lv_$check (rcp_id, lvid, (0), ecode);
	if ecode ^= 0 then
	     goto RETURN;				/* LV not attached for this process. */

	call admin_gate_$detach_lv (lvid, ecode);
	if ecode ^= 0 then
	     if ecode = error_table_$logical_volume_not_connected then
		ecode = 0;
	     else go to RETURN;			/* Unable to detach in ring 0. */

	/*** get information so we can audit the detachment.  This should all
	     be moved to a "lv_access_kernel_" module */
	call volume_registration_mgr_$find_lvname ((lvid), volume_name_str, ecode);
	if ecode ^= 0 then do;
	     volume_name_str = "logical volume UNKNOWN";
	     lv_access_range = sys_info$access_class_ceiling;
	end;
	else do;
	     call volume_registration_mgr_$get_access_for_attach (volume_name_str, (caller_level), ignore_mode,
		ignore_pubbit, lv_access_range, (0));
	     volume_name_str = "logical volume " || volume_name_str;
	end;

	string (auto_event_flags) = ""b;
	auto_event_flags.grant = "1"b;
	call access_audit_r1_$log_obj_class_range ("rcp_detach_lv_", caller_level, string (auto_event_flags),
	     access_operations_$detach_lv, lv_access_range, volume_name_str, (0), null (), (0));

	/*** and finally detach it */
	call rcp_lv_$del_lv (rcp_id, ecode);		/* Delete lv from process list. */

RETURN:
	arg_ecode = ecode;
	call cu_$level_set (caller_level);		/* Reset validation level. */

%page;
%include access_audit_eventflags;

     end rcp_detach_lv_;




		    rcp_device_info_.pl1            11/11/89  1110.3rew 11/11/89  0807.0      146880



/****^  ***********************************************************
        *                                                         *
        * 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(85-09-11,Fawcett), approve(85-09-11,MCR6979),
     audit(85-12-11,CLJones), install(86-03-21,MR12.0-1033):
     Add MCA support
                                                   END HISTORY COMMENTS */

/* format: style4 */

rcp_device_info_: procedure;

/*	This program is an internal interface of RCP.
   *	Created by Bill Silver on 12/12/74.
   *	Modified by D. Vinograd 6/76 to map model number 450 to 451
   *	Modified by Noel I. Morris on 01/20/77 for multiple tape controllers.
   *	Modified by D. Vinograd 2/77 to force access for Initializer process in ring 1.
   *	Modified by Michael R. Jordan on 11/17/78 to add version 2 tape_info structures and 6250 bpi.
   *	Modified by C. D. Tavares 04/27/79 for canonicalization.
   *	Modified by Michael R. Jordan 6/79 for MR7.0R.
   *	Modified by J. A. Bush 09/30/82 to return more tape info
   *	Modified by J. A. Bush 09/19/83 to fix a bug when using tape_info_version_3
   *	Modified by Chris Jones 03/05/85 to add copy entrypoint.
   *      Modified by Paul Farley & RAF 04/03/85 to add device_type (8) "MCA".
   *
   *	This program deals with the various RCP device info structures.
   *	It has the following entry points:
   *	     1.  get  -	Get data from a device info structure and put it into
   *			an RCSE.  Initialize the RCSE.
   *	     2.  put  -	Get data from an RCSE and put it into a device info structure.
   *	     3.  copy -	Copy data from one device info structure to another.
*/

/*		ARGUMENT  DATA		*/

dcl  arg_caller_level fixed bin;			/* (I) Caller's validation level. */
dcl  arg_device_info_ptr ptr;				/* (I) pointer to device info structure. */
dcl  arg_device_type char (*);			/* (I) Device type name. */
dcl  arg_ecode fixed bin (35);			/* (O) error_table_ code. */
dcl  arg_rcse_ptr ptr;				/* (I) Pointer to specified RCS entry. */


/*		AUTOMATIC  DATA		*/

dcl  access fixed bin (5);				/* Access to RCP system gate. */
dcl  am_initializer bit (1) initial ("0"b);		/* On if user is the Initializer */
dcl  caller_level fixed bin;				/* User's validation level. */
dcl  device_name char (32) aligned;			/* Device name. */
dcl  device_type char (32);				/* Device type name. */
dcl  dtypex fixed bin;				/* Index that => device type. */
dcl  ecode fixed bin (35);				/* error_table_ code. */
dcl  i fixed bin;
dcl  tracks fixed bin;				/* Tape tracks type qualifier. */

dcl  1 local_tape_info like tape_info;			/* A copy for handling version 1 structures. */


/*		BASED  DATA		*/

dcl  based_rcse (size (rcse)) bit (36) based (rcse_ptr);

dcl  1 version_1_tape_info based (device_info_ptr) aligned, /* O_L_D_ RCP device info structure for tapes. */
       2 version_num fixed bin,			/* Version number of this structure. */
       2 usage_time fixed bin,			/* Number of minutes drive will/may be used. */
       2 wait_time fixed bin,				/* Number of minutes user will/must wait. */
       2 system_flag bit (1),				/* ON => user wants to be a system process. */
       2 device_name char (8),			/* Tape drive name. */
       2 model fixed bin,				/* Tape drive model number. */
       2 tracks fixed bin,				/* Tracks type. */
       2 density bit (36),				/* Recording density: 200, 556, 800, 1600, 6250. */
       2 volume_name char (32),			/* Tape reel name. */
       2 write_flag bit (1),				/* ON => writing on tape reel. */
       2 position_index fixed bin (35);			/* Counter used to determine tape reel position. */

/*		EXTERNAL ENTRIES CALLED	*/

dcl  (addr, bit, null, size, string, substr) builtin;

dcl  (error_table_$bad_arg,
     error_table_$resource_unknown,
     error_table_$unimplemented_version) fixed bin (35) external;

dcl  get_group_id_ entry returns (char (32) aligned);
dcl  get_process_id_ entry returns (bit (36) aligned);
dcl  hcs_$get_user_effmode entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin,
	fixed bin (5), fixed bin (35));
dcl  rcp_pointers_$com_seg entry returns (ptr);
dcl  resource_info_$get_dtypex entry (char (*), char (*), fixed bin, fixed bin (35));

/*
   *
   *	This entry is called to get information out of a device info structure.
   *	We will interpret this information and put it into the specified RCS
   *	entry.  We will validate as much information in the structure as possible.
   *
*/


get: entry (arg_device_type, arg_device_info_ptr, arg_rcse_ptr, arg_caller_level, arg_ecode);


	device_type = arg_device_type;		/* Get arguments. */
	device_info_ptr = arg_device_info_ptr;
	rcse_ptr = arg_rcse_ptr;
	caller_level = arg_caller_level;

	call resource_info_$get_dtypex (device_type, device_type, dtypex, ecode);
	if ecode ^= 0 then goto RETURN_ERR;

	string (based_rcse) = "0"b;			/* Zero entire RCSE. */
	device_name,				/* Get name of device to assign. */
	     rcse.device_name = device_info.device_name;
	rcse.volume_name = " ";			/* Assume no volume. */
	rcse.dtypex = dtypex;			/* Remember device type. */
	rcse.model = device_info.model;		/* Every device type has a model number. */
	rcse.num_qualifiers = NUM_QUALIFIERS (dtypex);
	do i = 1 to rcse.num_qualifiers;		/* Fill in all qualifiers that device has. */
	     rcse.qualifiers (i) = device_info.qualifiers (i);
	end;

	rcse.caller_level = caller_level;		/* Fill in other data common to all device types. */
	rcse.process_id = get_process_id_ ();
	rcse.group_id = get_group_id_ ();
	rcse.version_num = device_info.version_num;
	rcse.workspace_ptr = null ();
	if device_name ^= " "			/* Not blank => looking for a specific device. */
	then rcse.flags.device = "1"b;
	rcse.flags.system = GET_SYSTEM_FLAG ();

	goto GET_DTYPE (dtypex);			/* Process according to device type. */


GET_DTYPE (1):					/* TAPE */
	if tape_info.version_num = 1 then do;		/* Convert old structures. */
	     local_tape_info.usage_time = version_1_tape_info.usage_time;
	     local_tape_info.wait_time = version_1_tape_info.wait_time;
	     local_tape_info.system_flag = version_1_tape_info.system_flag;
	     local_tape_info.device_name = version_1_tape_info.device_name;
	     local_tape_info.model = version_1_tape_info.model;
	     local_tape_info.tracks = version_1_tape_info.tracks;
	     local_tape_info.density = version_1_tape_info.density;
	     local_tape_info.speed = "0"b;
	     local_tape_info.pad = "0"b;
	     local_tape_info.volume_name = version_1_tape_info.volume_name;
	     local_tape_info.write_flag = version_1_tape_info.write_flag;
	     local_tape_info.position_index = version_1_tape_info.position_index;
	     device_info_ptr = addr (local_tape_info);	/* Switch to the temporary version 2 copy. */
	     rcse.qualifiers (3) = 0;			/* No speed in RCSE either. */
	end;
	else if tape_info.version_num ^= tape_info_version_3 & tape_info.version_num ^= tape_info_version_2
	then goto BAD_VERSION;
	call canon_name (DEVICE_TYPE (dtypex), device_name, rcse.device_name);
	if rcse.flags.device
	then do;					/* Specific device => no qualifier tests. */
	     if substr (device_name, 1, 3) ^= "tap"
	     then goto BAD_DEVICE;
	end;
	else do;					/* Any tape, check qualifiers. */
	     tracks = tape_info.tracks;		/* Get tracks type. */
	     if tracks ^= 0				/* If track qualifier specified validate it. */
	     then if (tracks ^= 9) &
		     (tracks ^= 7)
		then goto BAD_QUALIFIER;
	     if substr (tape_info.density, 6) ^= ""b	/* Extraneous bits set? */
	     then goto BAD_QUALIFIER;
	     if (tracks = 7) &			/* Did caller specify 7 track? */
		(substr (tape_info.density, 4, 2) ^= ""b)
						/* Then he can't specify possible 1600 or 6250 density. */
	     then goto BAD_QUALIFIER;
	     if substr (tape_info.speed, 4) ^= ""b	/* Extraneous bits set? */
	     then goto BAD_QUALIFIER;
	     if tape_info.pad ^= "0"b			/* This must be "0"b. */
	     then goto BAD_QUALIFIER;
	end;
	rcse.flags.writing = tape_info.write_flag;
	if tape_info.volume_name ^= " "		/* Is there a volume name? */
	then do;					/* Yes. */
	     rcse.volume_name = tape_info.volume_name;
	     rcse.flags.volume = "1"b;
	     if rcse.volume_name = "T&D_Volume"
	     then do;
		rcse.flags.t_and_d = "1"b;
		rcse.volume_name = "scratch";
	     end;
	     else call canon_name (VOLUME_TYPE (dtypex), rcse.volume_name, tape_info.volume_name);
	end;
	goto RETURN_OK;


GET_DTYPE (2):					/* DISK */
	if disk_info.version_num ^= 1
	then goto BAD_VERSION;
	call canon_name (DEVICE_TYPE (dtypex), device_name, rcse.device_name);
	if rcse.flags.device
	then if substr (device_name, 1, 3) ^= "dsk"
	     then goto BAD_DEVICE;
	rcse.flags.writing = disk_info.write_flag;
	if disk_info.volume_name ^= " "		/* Is there a volume name? */
	then do;					/* Yes. */
	     rcse.volume_name = disk_info.volume_name;
	     rcse.flags.volume = "1"b;
	     if rcse.volume_name = "T&D_Volume"
	     then do;
		rcse.flags.t_and_d = "1"b;
		rcse.volume_name = "scratch";
	     end;
	     else call canon_name (VOLUME_TYPE (dtypex), rcse.volume_name, disk_info.volume_name);
	end;
	if rcse.model = 191				/* Model number 191 replaced by 400. */
	then rcse.model = 400;
	if rcse.model = 450				/* then name been changed */
	then rcse.model = 451;
	goto RETURN_OK;


GET_DTYPE (3):					/* CONSOLE */
	if device_info.version_num ^= 1
	then goto BAD_VERSION;
	call canon_name (DEVICE_TYPE (dtypex), device_name, rcse.device_name);
	if rcse.flags.device			/* Does caller want a specific device? */
	then if substr (device_name, 1, 3) ^= "opc"	/* Then it must be this name: "opc". */
	     then goto BAD_DEVICE;
	rcse.model = 0;				/* Model number not used. */
	goto RETURN_OK;


GET_DTYPE (4):					/* PRINTER */
	if device_info.version_num ^= 1
	then goto BAD_VERSION;
	call canon_name (DEVICE_TYPE (dtypex), device_name, rcse.device_name);
	if rcse.flags.device
	then if substr (device_name, 1, 3) ^= "prt"
	     then goto BAD_DEVICE;
	goto RETURN_OK;


GET_DTYPE (5):					/* PUNCH */
	if device_info.version_num ^= 1
	then goto BAD_VERSION;
	call canon_name (DEVICE_TYPE (dtypex), device_name, rcse.device_name);
	if rcse.flags.device
	then if substr (device_name, 1, 3) ^= "pun"
	     then goto BAD_DEVICE;
	goto RETURN_OK;


GET_DTYPE (6):					/* READER */
	if device_info.version_num ^= 1
	then goto BAD_VERSION;
	call canon_name (DEVICE_TYPE (dtypex), device_name, rcse.device_name);
	if rcse.flags.device
	then if substr (device_name, 1, 3) ^= "rdr"
	     then goto BAD_DEVICE;
	goto RETURN_OK;


GET_DTYPE (7):					/* SPECIAL */
GET_DTYPE (8):					/* MCA */
	if device_info.version_num ^= 1
	then goto BAD_VERSION;
						/* Anything goes for name. */
	goto RETURN_OK;


RETURN_OK: arg_ecode = 0;
	device_info.device_name = rcse.device_name;	/* in case it was changed (canonicalized) */
	return;


RETURN_ERR:
	arg_ecode = ecode;
	return;


BAD_DEVICE:
	arg_ecode = error_table_$resource_unknown;
	return;


BAD_QUALIFIER:
	arg_ecode = error_table_$bad_arg;
	return;


BAD_VERSION:
	arg_ecode = error_table_$unimplemented_version;
	return;

canon_name: proc (resource_type, resource_name, copy_resource_name);


dcl  resource_type char (*);
dcl  (resource_name, copy_resource_name) char (*) aligned parameter,
     resource_info_$canonicalize_name ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));


	if am_initializer then
	     copy_resource_name = resource_name;	/* don't take chance RTDT nonexistent during reload */

	else do;
	     call resource_info_$canonicalize_name ((resource_type), resource_name, copy_resource_name, ecode);
	     if ecode ^= 0 then goto RETURN_ERR;
	end;

	resource_name = copy_resource_name;
	return;


     end canon_name;

/*
   *
   *	This entry is called to return information in a device info structure.
   *	The information about this device is take from the specified RCS entry.
   *
*/


set: entry (arg_device_info_ptr, arg_rcse_ptr, arg_ecode);


	device_info_ptr = arg_device_info_ptr;		/* Copy arguments. */
	rcse_ptr = arg_rcse_ptr;

	if device_info.version_num ^= rcse.version_num then /* verson number ^= */
	     if rcse.dtypex ^= TAPE_DRIVE_DTYPEX then	/* and not tapes */
		go to BAD_VERSION;
	     else if device_info.version_num ^= tape_info_version_3 & device_info.version_num ^= tape_info_version_2 then
		go to BAD_VERSION;

	device_info.usage_time,			/* Return common info. */
	     device_info.wait_time = 0;
	device_info.system_flag = rcse.flags.system;
	device_info.device_name = rcse.device_name;
	device_info.model = rcse.model;
	do i = 1 to rcse.num_qualifiers;
	     device_info.qualifiers (i) = rcse.qualifiers (i);
	end;

	goto SET_DTYPE (rcse.dtypex);			/* Process according to device type. */


SET_DTYPE (1):					/* TAPE */
	if device_info.version_num = 1 then do;		/* Old version version 1 structure. */
	     version_1_tape_info.volume_name = rcse.volume_name;
	     version_1_tape_info.write_flag = rcse.flags.writing;
	     version_1_tape_info.position_index = 1;	/* Feature not yet implemented. */
	end;
	else do;					/* Version 2 or > structure */
	     tape_info.volume_name = rcse.volume_name;
	     tape_info.write_flag = rcse.flags.writing;
	     tape_info.position_index = 1;		/* Feature not yet implemented. */
	     if tape_info.version_num = tape_info_version_3 then do; /* version 3 */
		tape_info.volume_density = rcse.volume_density_index;
		tape_info.volume_type = rcse.label_type;
		tape_info.opr_auth = rcse.need_auth;
	     end;
	end;
	arg_ecode = 0;
	return;


SET_DTYPE (2):					/* DISK */
	disk_info.volume_name = rcse.volume_name;
	disk_info.write_flag = rcse.flags.writing;
	arg_ecode = 0;
	return;


SET_DTYPE (3):					/* CONSOLE */
SET_DTYPE (4):					/* PRINTER */
SET_DTYPE (5):					/* PUNCH */
SET_DTYPE (6):					/* READER */
SET_DTYPE (7):					/* SPECIAL */
SET_DTYPE (8):					/* MCA */
	arg_ecode = 0;				/* No extra info to return. */
	return;

copy: entry (arg_device_type, arg_source_ptr, arg_dest_ptr, arg_ecode);

dcl  arg_source_ptr ptr parameter;
dcl  arg_dest_ptr ptr parameter;

dcl  source_ptr ptr;
dcl  dest_ptr ptr;
dcl  wordcount fixed bin;

dcl  based_bits (wordcount) bit (36) aligned based;

	device_type = arg_device_type;
	call resource_info_$get_dtypex (device_type, device_type, dtypex, ecode);
	if ecode ^= 0 then goto RETURN_ERR;

	source_ptr = arg_source_ptr;
	dest_ptr = arg_dest_ptr;
	wordcount = device_info_size (dtypex);
	dest_ptr -> based_bits = source_ptr -> based_bits;
	arg_ecode = 0;
	return;

/*
   *
   *	This procedure is called to determine whether or not the calling is to be
   *	considered a system process.  If it is a value of "1"b will be returned.
   *	Otherwise a value of "0"b will be returned.  In order to be considered
   *	a system process the following criteria must be satisified:
   *	     1.	The caller must want to be a system process.
   *	     2.	The caller must have access to the system RCP gate.
   *
   *	If the caller is the Initializer process in ring 1 then all is ok.
   *
*/


GET_SYSTEM_FLAG: procedure returns (bit (1));


	if rcse.group_id = "Initializer.SysDaemon.z" then do;
	     am_initializer = "1"b;
	     return ("1"b);
	end;

	if ^device_info.system_flag			/* Does caller want to be a system process? */
	then return ("0"b);				/* No. */

	rcs_ptr = rcp_pointers_$com_seg ();		/* Yes, see if caller has the necessary access. */
	call hcs_$get_user_effmode (rcs.sys_directory, rcs.sys_acs, rcse.group_id, caller_level,
	     access, ecode);
	if ecode ^= 0				/* Any error => no access. */
	then return ("0"b);

	if (bit (access, 5) & "00100"b) ^= "00100"b
	then return ("0"b);				/* Caller does not have "E" access. */

	return ("1"b);


     end GET_SYSTEM_FLAG;

%include rcp_com_seg;
%page;
%include rcp_resource_types;
%page;
%include rcp_device_info_structs;

     end rcp_device_info_;




		    rcp_disk_.pl1                   11/11/89  1110.3r w 11/11/89  0804.3      283284



/****^  ***********************************************************
        *                                                         *
        * 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(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(85-12-17,CLJones), install(86-03-21,MR12.0-1033):
     Add code for no
     PROTECT and OPR INT switches.
  2) change(86-01-15,Fawcett), approve(86-04-11,MCR7383),
     audit(86-06-17,Farley), install(86-07-17,MR12.0-1097):
     Add support for subvolumes and 512_WORD_IO.
  3) change(86-09-26,Farley), approve(86-10-24,MCR7557),
     audit(86-10-27,Fawcett), install(86-10-28,MR12.0-1200):
     Added call to admin_gate_$ioi_set_ws_max, before calling ioi_$workspace.
     This will allow proper workspace size setting when the workspace may be
     currently smaller than required.
                                                   END HISTORY COMMENTS */

rcp_disk_:
     procedure (arg_rcse_ptr, arg_ecode);

/*	This program is an internal interface of RCP.
   *	Created on 05/13/75 by Bill Silver.
   *	Changed on 04/02/76 by Bill Silver for NSS.
   *	Changed on 11/01/76 by Bill Silver to set mount timer.
   *	Changed on 12/02/76 by Bernard Greenberg for label countervalidator.
   *	Changed on 1/79 by R.J.C. Kissel to add disk label authentication.
   *	Changed 3/79 by Michael R. Jordan for MR7.0R.
   *	Changed 2/85 by Paul Farley to add code for no PROTECT and OPR INT switches.
   *
   *	This program is called to perform special disk attachment processing.
*/

/*		ARGUMENT  DATA		*/

	dcl     arg_ecode		 fixed bin (35);	/* (O) Return error_table_ code. */
	dcl     arg_rcse_ptr	 ptr;		/* (I) Pointer to attachment RCS entry. */


/*		AUTOMATIC  DATA		*/

	dcl     command		 bit (6);
	dcl     device_off		 bit (18) aligned;	/* RCPD device entry offset. */
	dcl     drive_num		 fixed bin;	/* Disk drive number. */
	dcl     (ecode, scode)	 fixed bin (35);	/* error_table_ code. */
	dcl     ioi_index		 fixed bin;	/* IOI internal device index. */
	dcl     label_address	 fixed bin;
	dcl     special_flag	 bit (1) aligned;	/* ON => special interrupt. */
	dcl     special_status_word	 bit (36) aligned;	/* One word of special status. */
	dcl     workspace_ptr	 ptr;		/* Pointer to our workspace. */
	dcl     real_story		 char (160);
	dcl     label_story		 char (160);
	dcl     what_user_asked_for	 bit (1);
	dcl     write_flag		 bit (1) aligned;
	dcl     valid_reg		 bit (1);		/* Pack has valid registration */
	dcl     ss_pack		 bit (1);		/* Pack is Storage System */
	dcl     valid_copy		 bit (1);		/* Pack is provably copy of mounted vol */
	dcl     (i, sector, record_factor, record_offset, cylinder, devadd, usable_sect_per_cyl, unused_sect_per_cyl) fixed bin (24); /* variables used to calculate label sector addresses */

/*		BASED  DATA		*/

	dcl     1 wspace		 based (workspace_ptr) aligned, /* Overlay of IOI workspace. */
		2 idcw		 bit (36),	/* Disk IDCW. */
		2 seek_dcw	 bit (36),	/* Used in label checking seek-read operation. */
		2 read_idcw	 bit (36),
		2 read_dcw	 bit (36),
		2 seek_addr	 bit (36),	/* Specifies record to seek. */
		2 state		 fixed bin,	/* Index that => current state of attachment. */
		2 mount_state	 fixed bin,	/* Save state used to wait for mounts. */
		2 retry_count	 fixed bin,	/* Number of REREADYs we have issued. */
		2 protect_comment	 char (8),	/* Used in disk mount messages. */
		2 flags,
		( 3 waiting_for_operator_interrupt
				 bit (1),		/* ON => interrupt must come from MPC button. */
		  3 pad1		 bit (35)
		  )		 unaligned,
		2 pad_ptr		 ptr,		/* Pad so status queue starts at even offset. */
		2 istatq		 like istat,	/* Our status queue - only 1 entry. */
		2 fs_type_idx	 fixed bin,	/* index into fs_devtype arrays for this device */
		2 n_label		 fixed bin,	/* number of labels */
		2 cur_label	 fixed bin,	/* what label currently checking */
		2 sv		 (3),		/* info on labels */
		  3 pvname	 char (32),	/* pv_name found in label */
		  3 story		 char (32),	/* Need this in wspace since it is used in different states. */

		2 label_buffer	 (1024) bit (36);	/* Area where we read pack label. */


/*		INTERNAL STATIC DATA	*/

	dcl     max_num_retries	 fixed bin /* Number of times we will ready a disk drive. */ internal static init (5);

	dcl     template_idcw	 bit (36) internal static init ("000000700201"b3);
						/* Template of the IDCW we will use. */

	dcl     set_standby_command	 bit (6) internal static init ("72"b3);
	dcl     request_status_command
				 bit (6) internal static init ("00"b3);
	dcl     read_command	 bit (6) internal static init ("25"b3);
	dcl     reset_status_command
				 bit (6) internal static init ("40"b3);
	dcl     LABEL_ADDRESS	 fixed bin (24) internal static init (0);

/*		EXTERNAL ENTRIES CALLED	*/

	dcl     (addr, bin, bit, divide, hbound, null, mod, rel, rtrim, size, substr)
				 builtin;

	dcl     (error_table_$bad_label, error_table_$device_attention, error_table_$invalid_state, error_table_$unable_to_do_io)
				 fixed bin (35) external;

	dcl     admin_gate_$ioi_set_ws_max
				 entry (fixed bin, fixed bin (19), fixed bin (35));
	dcl     admin_gate_$syserr	 entry options (variable);
	dcl     countervalidate_label_
				 entry (ptr, bit (1), bit (1), bit (1));
	dcl     cv_dec_		 entry (char (*), fixed bin);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     ioi_$connect	 entry (fixed bin, fixed bin, fixed bin (35));
	dcl     ioi_$get_special_status
				 entry (fixed bin, bit (1) aligned, bit (36) aligned, fixed bin (35));
	dcl     ioi_$set_status	 entry (fixed bin, fixed bin (18), fixed bin, fixed bin (35));
	dcl     ioi_$workspace	 entry (fixed bin, ptr, fixed bin (19), fixed bin (35));
	dcl     rcp_auto_register_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     rcp_ioi_attach_	 entry (ptr, fixed bin (35));
	dcl     rcp_mount_timer_$reset
				 entry (bit (18) aligned, fixed bin (35));
	dcl     rcp_mount_timer_$set
				 entry (bit (18) aligned, bit (1) aligned, fixed bin (35));
						/* 	*/
%include rcp_com_seg;

%include rcp_resource_types;
/* 	*/
%include fs_dev_types;
%include fs_vol_label;
/* 	*/
%include iom_pcw;
%include iom_dcw;
/* 	*/
%include ioi_stat;
/* 	*/
%include iom_stat;
/* 	*/
/*	Begin special disk attachment processing.
*/
	rcse_ptr = arg_rcse_ptr;			/* Copy argument. */
	workspace_ptr = rcse.workspace_ptr;		/* Get pointer to current workspace. */
	ecode = 0;

	if workspace_ptr ^= null ()			/* Have we set up a workspace yet? */
	then do;					/* Yes. */
		ioi_index = rcse.ioi_index;		/* Needed to call IOI. */
		isp = addr (wspace.istatq);		/* Almost every state needs this pointer. */
		goto DISK_STATE (wspace.state);	/* Go do next step in disk attachment. */
	     end;


/*	No workspace implies that this is the first call to rcp_$check_attach.
   *	We must attach the disk drive in ring 0 via IOI.
*/
	call rcp_ioi_attach_ (rcse_ptr, ecode);
	if ecode ^= 0				/* Any error at all? */
	then do;					/* Yes, abort attachment. */
		arg_ecode = ecode;
		return;
	     end;
	ioi_index = rcse.ioi_index;			/* Get IOI index for this attachment. */

/*	We have just attached the disk drive to IOI.  We must get an IOI workspace.
   *	Then we will issue a set standby command in order to power down this drive.
   *	For T&D attachments we don't want to do any of this special processing.
*/
	if rcse.flags.t_and_d			/* Is this a special T&D attachment? */
	then do;					/* Yes, nothing to do. */
		rcse.state = 4;			/* Tell caller that disk is ready for use. */
		arg_ecode = 0;
		return;
	     end;

	call admin_gate_$ioi_set_ws_max (ioi_index, size (wspace), ecode);
	if ecode ^= 0
	then do;
		arg_ecode = ecode;
		return;
	     end;

	call ioi_$workspace (ioi_index, workspace_ptr, size (wspace), ecode);
	if ecode ^= 0
	then do;
		arg_ecode = ecode;
		return;
	     end;

	rcse.workspace_ptr = workspace_ptr;		/* Save workspace pointer for this attachment. */
	wspace.idcw = template_idcw;			/* Set up template IDCW. */
	call cv_dec_ (substr (rcse.device_name, 6, 2), drive_num);
	addr (wspace.idcw) -> idcw.device = bit (bin (drive_num, 6));
	wspace.state,				/* Initialize the state variable that controls all. */ wspace.mount_state, wspace.retry_count = 0;
						/* Initialize retry count. */
	if rcse.flags.writing			/* Set up mount comment. */
	then wspace.protect_comment = "without";
	else wspace.protect_comment = "with";

	isp = addr (wspace.istatq);			/* Call IOI to set up our status queue. */
	call ioi_$set_status (ioi_index, bin (rel (isp), 18), 1, ecode);
	if ecode ^= 0
	then do;					/* Can't go on without a status queue. */
		arg_ecode = ecode;
		return;
	     end;

	if rcse.flags.preloaded | rcse.flags.not_removable_media
	then do;					/* In these cases we do not want to unload the disk */
		command = reset_status_command;
		wspace.state = 3;
		wspace.mount_state = 2;
	     end;
	else do;					/* UNLOAD the disk */
		command = set_standby_command;
		wspace.state = 1;
	     end;

/* find the device index from model number */
	do wspace.fs_type_idx = 1 to hbound (MODELN, 1) while (rcse.model ^= MODELN (wspace.fs_type_idx));
	end;
	wspace.n_label = number_of_sv (wspace.fs_type_idx);
	if wspace.n_label = 0 then wspace.n_label = 1;
	wspace.cur_label = 0;
	istat.completion.st = "0"b;			/* Try to put this disk drive in standby or reset status. */
	addr (wspace.idcw) -> idcw.command = command;
	call ioi_$connect (ioi_index, 0, ecode);
	arg_ecode = ecode;
	return;


/*	Somehow or other we are trying to use the workspace out of sequence.
*/
DISK_STATE (0):					/* INVALID STATE */
	arg_ecode = error_table_$invalid_state;
	return;


/*	The connect issued to perform the set standby has terminated.
   *	We don't really care whether or not the set standby operation worked.
   *	We will tell the operator to mount the disk volume being attached.
   *	Then we will wait for any special interrupts generated by a set standby
   *	or the mounting.
*/
DISK_STATE (1):					/* SET STANDBY TERMINATION */
	if ^istat.completion.st			/* There should at least be some status. */
	then return;				/* None, so ignore. */
						/* REQUEST DISK MOUNT */
	call admin_gate_$syserr (3, "RCP: Mount Pack ^a^[^s^; ^a protect^] on ^a for ^a", rcse.volume_name, rcse.flags.no_protect, wspace.protect_comment, rcse.device_name, rcse.group_id);
	wspace.state = 2;				/* Wait for special for mount. */
	wspace.mount_state = 2;			/* Remember state used to wait for mount. */
	wspace.flags.waiting_for_operator_interrupt = "0"b;
						/* Turn ON mount timer. */
	device_off = rcse.device_off;			/* Need RCPD device entry offset. */
	write_flag = rcse.flags.writing;		/* Pass on write flag. */
	call rcp_mount_timer_$set (device_off, write_flag, ecode);
	arg_ecode = ecode;
	return;


/*	We should come here because we have received a special interrupt.
   *	We will check to see if it was generated by the disk mount.
   *	If so bit # 36 should be ON.  If not we will wait for another special.
*/
DISK_STATE (2):					/* SPECIAL from MOUNT. */
	call ioi_$get_special_status (ioi_index, special_flag, special_status_word, ecode);

/*
   Check for: an error return, not a special, the wrong special, or not a special from the MPC.
*/

	arg_ecode = ecode;

	if ecode ^= 0 | ^special_flag
	then return;				/* Not a special. */

	else do;					/* A good special. */
		if wspace.flags.waiting_for_operator_interrupt
		then do;				/* Make sure it is from MPC butoon. */
			if substr (special_status_word, 20, 1) ^= "1"b | substr (special_status_word, 13, 6) ^= "00"b3
			then return;
		     end;				/* Make sure it is from MPC button. */

		else do;				/* Make sure it is from a device. */
			if substr (special_status_word, 34, 3) ^= "001"b
			then return;
		     end;				/* Make sure it is from a device. */
	     end;					/* A good special. */

	istat.completion.st = "0"b;			/* DISK READY - check its current state. */
	addr (wspace.idcw) -> idcw.command = request_status_command;
	call ioi_$connect (ioi_index, 0, ecode);
	wspace.state = 3;				/* Wait for request status to terminate. */

	device_off = rcse.device_off;			/* Turn OFF mount timer. */
	call rcp_mount_timer_$reset (device_off, scode);
	if ecode = 0
	then ecode = scode;

	rcse.flags.disk_ss_pack = "0"b;
	rcse.flags.disk_copy_of_ss_pack = "0"b;
	rcse.flags.disk_io_pack = "0"b;
	rcse.flags.disk_unregistered = "0"b;
	rcse.flags.disk_unreadable = "0"b;
	arg_ecode = ecode;
	return;


/*	Check the status from the request (or reset) status operation.  We must check that
   *	write protect is set correctly.  If everything is OK we will indicate that
   *	the attachment has been completed.
*/
DISK_STATE (3):					/* REQUEST (or RESET) STATUS TERMINATION. */
	if ^istat.completion.st			/* Is there any status. */
	then do;					/* No, ignore. */
		arg_ecode = 0;
		return;
	     end;

	if istat.level ^= 3				/* Is this a terminiate? */
	then do;					/* No, something wrong. */
		call REREADY_DISK ("0"b, "0"b);
		arg_ecode = ecode;
		return;
	     end;

	statp = addr (istat.iom_stat);		/* Get pointer to IOM status. */
	if istat.completion.er			/* Test for error that is not an Attention with Protect. */
	then if (status.major ^= "0010"b) | (status.sub ^= "000001"b)
	     then do;				/* That is what we have. */
		     call REREADY_DISK ("0"b, "0"b);
		     arg_ecode = ecode;
		     return;
		end;

/*	Now check that the write protect is set correctly.  If the user
   *	wants to write then protect should be OFF and the major status should
   *	be Ready and thus there should be no error.  If the user does not want
   *	to write then protect should be ON and the status should be Device
   *	Attention with Protect and there should be an error.
*/
	if rcse.flags.writing = istat.completion.er &
	     ^rcse.flags.no_protect			/* device has protect sw. */
	then do;					/* Protect is not set correctly. */
		call REREADY_DISK ("0"b, "1"b);
		arg_ecode = ecode;
		return;
	     end;

/*	Set up channel program to read label  of pack.  We want to verify that this
   *	pack is not a storage system pack.  Only users acting as system processes
   *	may mount a storage system pack for user I/O.
*/
	idcwp = addr (wspace.idcw);			/* Set up a seek for the label record. */
	idcw.command = seek_command (wspace.fs_type_idx); /* Get correct seek type for this dev */
	idcw.control = "10"b;			/* Continue to next IDCW. */
	idcw.count = "0"b;

	wspace.seek_dcw = "0"b;			/* Set up seek DCW. */
	dcwp = addr (wspace.seek_dcw);
	dcw.address = rel (addr (wspace.seek_addr));
	dcw.tally = bit (bin (1, 12));

	wspace.read_idcw = "0"b;			/* Set up to read on record. */
	idcwp = addr (wspace.read_idcw);
	idcw.command = read_command;
	idcw.device = addr (wspace.idcw) -> idcw.device;
	idcw.code = "111"b;

	wspace.read_dcw = "0"b;			/*  Set up read DCW. */
	dcwp = addr (wspace.read_dcw);
	dcw.address = rel (addr (wspace.label_buffer));
	dcw.tally = bit (bin (size (label), 12), 12);



LABEL_LOOP:
	wspace.cur_label = wspace.cur_label + 1;
	label_address = LABEL_ADDRESS;
	if wspace.cur_label > 1 then do;

		record_factor = (wspace.cur_label - 1) * rec_per_cyl (wspace.fs_type_idx);
		record_offset = mod (label_address, rec_per_cyl (wspace.fs_type_idx));
		devadd = ((label_address - record_offset) * wspace.n_label) +
		     record_factor + record_offset;
		sector = devadd * sect_per_rec (wspace.fs_type_idx); /* raw sector. */
		usable_sect_per_cyl =
		     divide (sect_per_cyl (wspace.fs_type_idx), sect_per_rec (wspace.fs_type_idx), 24, 0) *
		     sect_per_rec (wspace.fs_type_idx);
		unused_sect_per_cyl = sect_per_cyl (wspace.fs_type_idx) - usable_sect_per_cyl;
		cylinder = divide (sector, usable_sect_per_cyl, 12, 0);
		sector = sector + cylinder * unused_sect_per_cyl;
	     end;
	else sector = label_address;
	wspace.seek_addr = bit (bin (sect_per_rec (wspace.fs_type_idx), 12), 12) ||
	     bit (bin (sector, 24), 24);

	istat.completion.st = "0"b;			/* Reset before connect.  */
	call ioi_$connect (ioi_index, 0, ecode);
	if ecode ^= 0
	then do;					/* Bad error from IOI. */
		arg_ecode = ecode;
		return;
	     end;

	wspace.state = 4;
	return;

/*	Check the status from the seek and read request.
*/
DISK_STATE (4):					/* SEEK and READ TERMINATION */
	if ^istat.completion.st			/* Did we get a real interrupt? */
	then do;					/* No, ignore. */
		arg_ecode = 0;
		return;
	     end;

	if istat.level ^= 3				/* Is it a termination? */
	then do;					/* No, must be an unwanted special. */
		call REREADY_DISK ("0"b, "0"b);
		arg_ecode = ecode;
		return;
	     end;

/* Initialize for label checking. */
	wspace.n_label = number_of_sv (wspace.fs_type_idx);
	if wspace.n_label = 0 then wspace.n_label = 1;

	labelp = addr (wspace.label_buffer);		/* Always need this whether the read was successful or not. */

	statp = addr (istat.iom_stat);		/* Check termination status. */
	if istat.completion.er			/* Did we get an error? */
	then do;					/* An error reading the label. */
		if rcse.flags.system
		then do;				/* System processes get a chance to authenticate. */
			label.pv_name = "";		/* Blank this for authentication message. */
			sv (wspace.cur_label).pvname = label.pv_name;
			wspace.sv (wspace.cur_label).story = "UnReaDable";
			rcse.flags.disk_unreadable = "1"b;
		     end;

		else do;				/* Normal people don't. */
			arg_ecode = error_table_$unable_to_do_io;
			return;
		     end;
	     end;					/* An error reading the label. */

	else do;					/* Check the label. */
		sv (wspace.cur_label).pvname = label.pv_name;
		call countervalidate_label_ (labelp, valid_reg, valid_copy, ss_pack);

		if ss_pack
		then do;				/* Some sort of known pack. */

			if valid_copy
			then do;
				wspace.sv (wspace.cur_label).story = "copy of Storage System";
				rcse.flags.disk_copy_of_ss_pack = "1"b;
			     end;

			else if valid_reg
			then do;
				wspace.sv (wspace.cur_label).story = "Storage System";
				rcse.flags.disk_ss_pack = "1"b;
			     end;

			else do;
				wspace.sv (wspace.cur_label).story = "UnReGistered";
				rcse.flags.disk_unregistered = "1"b;
			     end;

			if ^rcse.flags.system
			then do;			/* Normal people can't use these. */
				call admin_gate_$syserr (0, "RCP: Rejected mount of ^a volume ^a for ^a.",
				     wspace.sv (wspace.cur_label).story, wspace.sv (wspace.cur_label).pvname, rcse.group_id);
				arg_ecode = error_table_$bad_label;
				return;
			     end;			/* Normal people can't use these. */
		     end;				/* Some sort of known pack. */

		else do;				/* An unknown pack. */
			label.pv_name = "";		/* Blank this for authentication message. */
			wspace.sv (wspace.cur_label).pvname = label.pv_name;
			wspace.sv (wspace.cur_label).story = "IO";
			rcse.flags.disk_io_pack = "1"b;
		     end;				/* An unknown pack. */
	     end;					/* Check the label. */

/* Initialize for the authentication state. */

	rcse.flags.have_auth = "0"b;
	rcse.flags.need_auth = "0"b;
	rcse.flags.auth_set = "0"b;

/*
   Everybody (except the Initializer) must get authenticated at this point.  User processes only get
   here if the label was readable and not a registered or unregistered storage system pack.
   System processes always get here with an appropriate story.
*/

	if rcse.group_id = "Initializer.SysDaemon.z"
	then do;					/* Set flags so Initializer does'nt need authentication. */
		rcse.flags.have_auth = "1"b;
		rcse.flags.auth_set = "1"b;
		rcse.flags.need_auth = "0"b;
	     end;

/* check for all labels read */

	if wspace.cur_label < n_label then do;
		wspace.state = 3;
		goto LABEL_LOOP;
	     end;

DISK_STATE (5):					/* The authentication state. */
	wspace.state = 5;

	labelp = addr (wspace.label_buffer);		/* Always need this for messages. */

	if rcse.flags.auth_set			/* Note that this will be false the first time. */
	then do;					/* Check whether authenticated or not. */
		if rcse.flags.have_auth
		then do;				/* Everything is done. */
			device_off = rcse.device_off;
			call rcp_mount_timer_$reset (device_off, scode);
						/* Turn OFF mount timer. */
			do i = 1 to wspace.n_label;
			     call admin_gate_$syserr (0, "RCP: Mounted ^a volume ^a on ^a^[^a^] for user I/O.",
				wspace.sv (i).story, wspace.sv (i).pvname, rcse.device_name, (n_label > 1), substr (valid_sv_string, i, 1));
			end;
			call ioi_$set_status (ioi_index, 0, 0, ecode);
			if ecode ^= 0
			then do;			/* Bad error. */
				arg_ecode = ecode;
				return;
			     end;			/* Bad error. */

			if rcse.flags.must_auto_register
			then do;			/* Register this disk_vol to this user. */
				call rcp_auto_register_ (VOLUME_TYPE (DISK_VOL_VTYPEX), (rcse.volume_name), (rcse.group_id), ecode);
				if ecode ^= 0	/* ERROR */
				then do;
					arg_ecode = ecode;
					return;
				     end;
			     end;

			rcse.state = 4;
			wspace.state = 0;
			arg_ecode = scode;		/* Not a fatal error. */
			return;
		     end;				/* Everything is done. */

		else do;				/* Bad authentication. */
			device_off = rcse.device_off;
			call rcp_mount_timer_$reset (device_off, scode);
						/* Turn OFF mount timer. */

			call admin_gate_$syserr (3, "RCP: Authentication denied for ^a.", rcse.device_name);

			if rcse.flags.not_removable_media
			then do;			/* Nothing we can do about this. */
				arg_ecode = error_table_$bad_label;
				return;
			     end;

			else do;			/* Give the operator another chance. */
				istat.completion.st = "0"b;
				addr (wspace.idcw) -> idcw.command = set_standby_command;
				call ioi_$connect (ioi_index, 0, ecode);
						/* Ignore the code. */

				wspace.retry_count = 0;
						/* Start over. */
				call REREADY_DISK ("1"b, "0"b);
						/* Authentication denied. */
				arg_ecode = ecode;
				return;
			     end;			/* Give the operator another chance. */
		     end;				/* Denied authentication. */
	     end;					/* Check whether authenticated or not. */

	else do;					/* Tell operator to authenticate, type of pack is already set. */

		if ^rcse.flags.need_auth
		then do;				/* Authentication is needed. */
			rcse.flags.need_auth = "1"b;
			rcse.flags.auth_set = "0"b;
			rcse.flags.have_auth = "0"b;

			if wspace.n_label > 1 then do;
				real_story = "";
				what_user_asked_for = "0"b;
				if rcse.flags.disk_ss_pack then do;
					real_story = "a Storage System";
					rcse.flags.disk_copy_of_ss_pack = "0"b;
					rcse.flags.disk_io_pack = "0"b;
					rcse.flags.disk_unregistered = "0"b;
					rcse.flags.disk_unreadable = "0"b;
				     end;
				else if rcse.flags.disk_copy_of_ss_pack then do;
					real_story = "a copy of Storage System";
					rcse.flags.disk_io_pack = "0"b;
					rcse.flags.disk_unregistered = "0"b;
					rcse.flags.disk_unreadable = "0"b;
				     end;
				else if rcse.flags.disk_unregistered then do;
					real_story = "an UnReGistered";
					rcse.flags.disk_io_pack = "0"b;
					rcse.flags.disk_unreadable = "0"b;
				     end;
				else if rcse.flags.disk_io_pack then do;
					real_story = "an IO";
					rcse.flags.disk_unreadable = "0"b;
				     end;
				else if rcse.flags.disk_unreadable then do;
					real_story = "an UnReaDable label.";
					call ioa_$rsnnl ("All ^d subvolume labels are unreadable.", label_story, (0), wspace.n_label);
					goto TELL_STORY;
				     end;

				call ioa_$rsnnl ("^a label.", real_story, (0), rtrim (real_story));
				label_story = "";
				do i = 1 to wspace.n_label;
				     call ioa_$rsnnl ("^a^x^[no label for^s^;^a on^] subvol ^a^[.^;,^]",
					label_story, (0), rtrim (label_story), (wspace.sv (i).pvname = ""), wspace.sv (i).pvname,
					valid_sv_array (i - 1), (i = wspace.n_label));
				     if wspace.sv (i).pvname = rcse.volume_name
				     then what_user_asked_for = "1"b;
				end;
TELL_STORY:
				call admin_gate_$syserr (3, "RCP: Authenticate ^a for ^a.^/^8xRCP: It has ^a^/^8xRCP:^a^[^s^;^/^8xRCP: User requested volume ^a.^]^[
RCP: WARNING!!  IF YOU AUTHENTICATE THIS REQUEST ^a WILL OWN VOLUME ^a!^]",
				     rcse.device_name, rcse.group_id,
				     real_story, label_story, what_user_asked_for, rcse.volume_name,
				     rcse.flags.must_auto_register, rcse.group_id, rcse.volume_name);
			     end;
			else do;
				call admin_gate_$syserr (3,
				     "RCP: Authenticate ^a for ^a.^/^8xRCP: It has ^a label ^a.^[^s^;^/^8xRCP: User requested volume ^a.^]^[
RCP: WARNING!!  IF YOU AUTHENTICATE THIS REQUEST ^a WILL OWN VOLUME ^a!^]",
				     rcse.device_name, rcse.group_id, wspace.sv (1).story, wspace.sv (1).pvname,
				     wspace.sv (1).pvname = rcse.volume_name, rcse.volume_name,
				     rcse.flags.must_auto_register, rcse.group_id, wspace.sv (1).pvname);
			     end;
			device_off = rcse.device_off;
			write_flag = rcse.flags.writing;
			call rcp_mount_timer_$set (device_off, write_flag, scode);
						/* Turn ON mount timer. */

			arg_ecode = 0;		/* Ignore code from timer setting. */
			return;
		     end;				/* Authentication is needed. */

		else do;				/* Ignore some spurious wakeups. */
			arg_ecode = 0;
			return;
		     end;
	     end;					/* Tell operator to authenticate. */
						/* 	*/
REREADY_DISK:
     procedure (remount_flag, protect_flag);

/*	This procedure is called to tell the operator to ready the disk again.
   *	We will have to wait for the special again.
*/
	dcl     remount_flag	 bit (1);		/* ON => remount,  OFF => reready. */
	dcl     protect_flag	 bit (1);		/* ON => protect wrong, OFF => protect ok. */

	if wspace.retry_count = max_num_retries		/* Have we retried too many times. */
	then do;					/* Yes, abort attachment. */
		ecode = error_table_$device_attention;
		return;
	     end;
	wspace.retry_count = wspace.retry_count + 1;

	device_off = rcse.device_off;			/* Turn ON mount timer. */
	write_flag = rcse.flags.writing;		/* Pass on write flag. */
	call rcp_mount_timer_$set (device_off, write_flag, ecode);
	if ecode ^= 0
	then return;

	if protect_flag & rcse.flags.opr_int_available
	then do;					/* Must change protect switch on drive. */
		call admin_gate_$syserr (3,
		     "RCP: Turn protect switch ^[OFF^;ON^] on drive ^a and then push Operator Interrupt on MPC.",
		     rcse.flags.writing, rcse.device_name);
		wspace.state = wspace.mount_state;
		wspace.flags.waiting_for_operator_interrupt = "1"b;
	     end;					/* Must change protect switch on drive. */

	else do;
		if remount_flag			/* Remount or ready? */
		then call admin_gate_$syserr (3, "RCP: Wrong pack (^a) mounted on ^a.  Mount pack ^a^[^s^; ^a protect^] on ^a",
			label.pv_name, rcse.device_name, rcse.volume_name, rcse.flags.no_protect, wspace.protect_comment, rcse.device_name);
		else call admin_gate_$syserr (3, "RCP: Reready ^a^[^s^; ^a protect^]", rcse.device_name, rcse.flags.no_protect, wspace.protect_comment);

		wspace.state = wspace.mount_state;	/* Wait for special from mount again. */
		wspace.flags.waiting_for_operator_interrupt = "0"b;
	     end;

     end REREADY_DISK;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Mount Pack PACK with(out) protect on DRIVE for PERSON.PROJ.T

   S:	$beep

   T:	$run

   M:	The user PERSON.PROJ.T has requested the mounting of
   the user I/O pack named PACK on disk drive DRIVE.

   A:	Mount the pack and make it ready.
   Set the PROTECT status as specified in the message.


   Message:
   RCP: Mount Pack PACK on DRIVE for PERSON.PROJ.T

   S:	$beep

   T:	$run

   M:	The user PERSON.PROJ.T has requested the mounting of
   the user I/O pack named PACK on disk drive DRIVE.

   A:	Mount the pack and make it ready.


   Message:
   RCP: Turn protect switch ON/OFF on drive DRIVE and then push Operator Interrupt on MPC

   S:	$beep

   T:	$run

   M:	The PROTECT status was wrong for DRIVE.

   M:	Correct the PROTECT status and push the Operator Interrupt button on the MPC.


   Message:
   RCP: Reready DRIVE with(out) protect

   S:	$beep

   T:	$run

   M:	DRIVE is not ready.


   A:	Make the drive ready.


   Message:
   RCP: Reready DRIVE

   S:	$beep

   T:	$run

   M:	DRIVE is not ready.


   A:	Make the drive ready.


   Message:
   RCP: Rejected mount of LABEL_TYPE volume NAME for PERSON.PROJ.T

   S:	$info

   T:	$run

   M:	A user has attempted to mount a storage-system format or unreadable (LABEL_TYPE)
   disk pack for user I/O, without specifying the -sys parameter.
   Because this might interfere with later storage system use of the pack
   or compromise system security,
   this action is not permitted.
   The user's request is rejected.
   This error could arise if an operator inadvertently mounted
   the wrong pack.

   A:	$ignore


   Message:
   RCP: Mounted LABEL_TYPE volume NAME on DRIVE for user I/O.

   S:	$info

   T:	$run

   M:	A user has mounted LABEL_TYPE volume NAME as a user I/O disk on DRIVE.
   The operator has authenticated the mount.

   A:	$ignore


   Message:
   RCP: Authenticate DRIVE for PERSON.PROJ.T.
.brf
RCP: It has LABEL_TYPE label NAME.
.brf;.unl 1
(RCP: All N subvolume labels are unreadable.)
.brf;.unl 1
(RCP: VOL_NAME on subvol a, VOL_NAME on subvol b, VOL_NAME on subvol c.)
.brf;.unl 1
(RCP: User requested volume DIFFERENT_NAME.)

   S:	$beep

   T:	$run

   M:	The operator must verify that the correct pack is mounted on DRIVE.
   If the DIFFERENT_NAME message indicates that the label on the
   pack (NAME) is different from the user's request then special
   instructions from the system administrator must be followed.

   A:	If the pack is correct then use the "x auth" function to input the
   DRIVE and the authentication code which matches LABEL_TYPE:  "ss"
   for "Storage System" or "copy of Storage System"; "io" for "IO";
   "urd" for "UnReaDable"; or "urg" for "UnReGistered".  If the wrong
   pack is mounted then use the authentication code "no".


   Message:
   RCP: Authentication denied for DRIVE

   S:	$beep

   T:	$run

   M:	The operator has denied authentication for DRIVE.

   A:	$ignore


   Message:
   RCP: Wrong pack (NAME) mounted on DRIVE. Mount pack PACK with(out) protect on DRIVE.

   S:	$beep

   T:	$run

   M:	The operator has denied authentication for a removable disk pack (NAME)
   on drive DRIVE.  The disk drive is put in standby.

   A:	Mount the correct pack PACK with protect as specified and ready drive.


   Message:
   RCP: Wrong pack (NAME) mounted on DRIVE. Mount pack PACK on DRIVE.

   S:	$beep

   T:	$run

   M:	The operator has denied authentication for a removable disk pack (NAME)
   on drive DRIVE.  The disk drive is put in standby.

   A:	Mount the correct pack PACK with protect as specified and ready drive.


   Message:
   RCP: WARNING!!  IF YOU AUTHENTICATE THIS REQUEST <USER> WILL OWN VOLUME <VOLUME>!

   S:	$beep

   T:	$run

   M:	This is a warning to the operator.  He should be very careful to check the
   physical label of the volume before authenticating this request.  As the message states,
   if the request is autheticated, <VOLUME> will be registered and acquired to <USER>.

   A:	Check the physical label of the disk pack.  If it is the property of
   <USER>, authenticate the request.  If it is not the property of <USER> deny the
   request by typing "x auth no".


   END MESSAGE DOCUMENTATION */

     end rcp_disk_;




		    rcp_find_.pl1                   11/11/89  1110.3r   11/11/89  0805.9       70560



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


rcp_find_: procedure;

/*	This program is an internal interface of RCP.
   *	Created on 12/04/74 by Bill Silver.
   *	Modified 6/79 by Michael R. Jordan for MR7.0R.
   *
   *	This program is called to find a device that is already assigned
   *	or attached to the calling process.  If successful we will return
   *	the offset of the RCS entry that corresponds to this device.
   *	This program has the following entry points:
   *	     1.	attached   -  Find a device or volume that is attached.
   *	     2.	device	 -  Find a device that is assigned given its name.
   *	     3.	unattached -  Find a device that is assigned and not attached.
*/

/*		ARGUMENT  DATA		*/

dcl  arg_device_name char (*);			/* (I) name of device to find. */
dcl  arg_rcse_ptr ptr;				/* (I) Pointer to RCS entry to match. */
dcl  arg_trcse_off bit (18);				/* (O) Offset of RCS entry that matched. */


/*		AUTOMATIC  DATA		*/

dcl  match_list (16) ptr;				/* List of devices that match. */

dcl  assign_off bit (18);				/* Offset of first assignment RCS entry. */
dcl  attach_off bit (18);				/* Offset of first attachment RCS entry. */
dcl  device_name char (32);				/* Name of device we are looking for. */
dcl  match_flag bit (1);				/* ON => matching attach RCS entries. */
dcl  num_assign fixed bin;				/* Number of devices assigned to process. */
dcl  num_attach fixed bin;				/* Number of devices attached to process. */
dcl  num_match fixed bin;				/* Number of devices that match. */
dcl  trcse_off bit (18);				/* Offset  of a test RCS entry. */
dcl  trcse_ptr ptr;					/* Pointer to a test RCS entry. */


/*		BASED  DATA		*/

dcl 1 trcse based (trcse_ptr) like rcse aligned;		/* Used to reference a test RCS entry. */


/*		EXTERNAL ENTRIES CALLED	*/

dcl (addr, ptr, rel) builtin;

dcl  rcp_match_$match entry (ptr, ptr) returns (bit (1));
dcl  rcp_match_$select entry (ptr, fixed bin, char (*) aligned, ptr);
dcl  rcp_pointers_$com_seg entry returns (ptr);
dcl  rcp_rcse_$info entry (bit (18), fixed bin, bit (18), fixed bin);

%include rcp_com_seg;

attached:	entry (arg_rcse_ptr, arg_trcse_off);

/*	This entry point will look for an attachment RCS entry that matches
   *	the specified RCS entry.  If we are looking for a volume or a
   *	specific device and we find either of them then we will have
   *	found a matching entry.
*/
	rcse_ptr = arg_rcse_ptr;			/* Get pointer to RCS entry to match. */
	rcs_ptr = rcp_pointers_$com_seg ();

/* Get list of devices attached to process. */
	call rcp_rcse_$info (attach_off, num_attach, assign_off, num_assign);

	match_flag = "0"b;				/* Assume no matching attach entry. */
	trcse_off = attach_off;			/* Start with first attachment RCS entry. */

	do while (trcse_off ^= "0"b);			/* Test all attachment RCS entries. */
	     trcse_ptr = ptr (rcs_ptr, trcse_off);
	     call MATCH_ATTACH;			/* See if this RCS entry matches. */
	     if match_flag				/* Did it match? */
	     then do;				/* Yes, return offset of entry that matched. */
		arg_trcse_off = trcse_off;
		return;
	     end;
	     trcse_off = trcse.user_off;		/* Get next attachment RCS entry. */
	end;

	arg_trcse_off = "0"b;			/* No matching attachment. */
	return;

device:	entry (arg_device_name, arg_trcse_off);

/*	This entry is called to find a device that is assigned.  We are
   *	looking for a specific device name and will not bother matching any
   *	other device characteristics.  We do not care if the device is also
   *	attached.
*/
	device_name = arg_device_name;		/* Initialize. */
	rcs_ptr = rcp_pointers_$com_seg ();

/* Get list of devices assigned to process. */
	call rcp_rcse_$info (attach_off, num_attach, assign_off, num_assign);

	trcse_off = assign_off;			/* Start with first device in the list. */
	do while (trcse_off ^= "0"b);			/* Test each device in assignment list. */
	     trcse_ptr = ptr (rcs_ptr, trcse_off);	/* Get pointer to device to test. */
	     if device_name = trcse.device_name		/* Is this the device we are looking for? */
	     then do;				/* Yes, return its RCS entry. */
		arg_trcse_off = trcse_off;
		return;
	     end;
	     trcse_off = trcse.user_off;		/* Get next device in assignment list. */
	end;

	arg_trcse_off = "0"b;			/* We did not find the specified device. */
	return;

unattached: entry (arg_rcse_ptr, arg_trcse_off);

/*	This entry is called to find a device that is assigned to the calling
   *	process but is not attached.  The input RCS entry is used to specify
   *	the characteristics of the device that we are looking for.  We will
   *	generate a list of all assigned but unattached devices that match
   *	these characteristics.  From that list we will choose the best device.
*/
	rcse_ptr = arg_rcse_ptr;			/* Initialize. */
	rcs_ptr = rcp_pointers_$com_seg ();

/* Get list of devices assigned to process. */
	call rcp_rcse_$info (attach_off, num_attach, assign_off, num_assign);

	num_match = 0;				/* No devices match yet. */
	trcse_off = assign_off;			/* Start with first device on the list. */

	do while (trcse_off ^= "0"b);			/* Test all devices in assignment list. */
	     trcse_ptr = ptr (rcs_ptr, trcse_off);
	     call MATCH_ASSIGN;			/* See if this device matches. */
	     trcse_off = trcse.user_off;		/* Get next device in the assignment list. */
	end;

	if num_match = 0				/* Did any devices match? */
	then do;					/* No. */
	     arg_trcse_off = "0"b;
	     return;
	end;

/* Yes, select the best one. */
	call rcp_match_$select (addr (match_list), num_match, rcse.volume_name, trcse_ptr);
	arg_trcse_off = rel (trcse_ptr);		/* Return offset of selected device. */
	return;

MATCH_ATTACH: procedure;

/*	This procedure is called to see if the current attached device matches
   *	the device name or volume name of the device that is being attached.
*/
	     if (rcse.flags.device) &			/* Are we looking for a specific device? */
	     (rcse.device_name = trcse.device_name)
	     then do;				/* Yes, and this is it. */
		match_flag = "1"b;			/* Tell caller that we found a match. */
		return;
	     end;

	     if rcse.flags.volume			/* Are we looking for a volume? */
	     then if (rcse.volume_name ^= "scratch") &
		(rcse.volume_name = trcse.volume_name)
		then match_flag = "1"b;		/* Yes, a non scratch volume that matches. */

	end MATCH_ATTACH;

MATCH_ASSIGN: procedure;

/*	This procedure is called to see if the current assigned device matches
   *	the requirements of the specified device.  Only devices that are not
   *	attached can match.
*/
	     if rcse.dtypex ^= trcse.dtypex		/* No match if not same device type. */
	     then return;

	     if trcse.state ^= 5			/* Is assignment complete? */
	     then return;				/* No, then no match. */

	     if trcse.rcse_off ^= "0"b		/* Is device attached? */
	     then return;				/* Yes, no match. */

/* See if device characteristics match. */
	     match_flag = rcp_match_$match (rcse_ptr, trcse_ptr);
	     if match_flag				/* Do they match? */
	     then do;				/* Yes. */
		num_match = num_match + 1;		/* Up count of devices that have matched. */
		match_list (num_match) = trcse_ptr;	/* Save pointer to this device in our list. */
	     end;

	end MATCH_ASSIGN;

     end rcp_find_;




		    rcp_force_unassign_.pl1         11/11/89  1110.3r   11/11/89  0805.9       80064



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


rcp_force_unassign_: procedure;

/*	This program implements the rcp_sys_$unassign_device
   *	and rcp_sys_$unassign_process entries.
   *	Created on 12/09/74 by Bill Silver.
   *      Modified 841009 to interface to rcp_control_ instead of
   *         rcp_initializer_... -M. M. Pozzo
   *
   *	This program contains the following entry points:
   *	     1.	unassign_device  -	Unassign a device regardless of process.
   *	     2.	unassign_process -	Unassign all resources assigned to a process.
*/

/*		ARGUMENT  DATA		*/

	dcl     arg_device_name	 char (*);	/* (I) Device name. */
	dcl     arg_ecode		 fixed bin (35);	/* (O) error_table_ code. */
	dcl     arg_process_id	 bit (36) aligned;	/* (I) Process ID. */


/*		AUTOMATIC  DATA		*/

	dcl     device_offset	 bit (18) aligned;
	dcl     lock_flag		 bit (1) aligned;	/* ON => RCS locked. */
	dcl     process_flag	 bit (1) aligned;	/* ON => using process ID. */
	dcl     process_id		 bit (36) aligned;	/* Process ID. */
	dcl     volume_offset	 bit (18) aligned;

	dcl     operation		 bit (36) aligned;	/* Operation being requested of rcp_control_. */
	dcl     device_name		 char (32);	/* Device name. */

	dcl     caller_level	 fixed bin;	/* Caller's validation level. */
	dcl     bump_message	 fixed bin (71);	/* Cell for device preempt message */
	dcl     ecode		 fixed bin (35);	/* error_table_ code. */
	dcl     error_count		 fixed bin (17);	/* error count for device attachments. */
	dcl     i			 fixed bin;


/*		CONSTANT DATA		*/

	dcl     BUMP_MESSAGE	 char (8) static options (constant) init ("RCP_BUMP");

/*		EXTERNAL ENTRIES CALLED	*/

	dcl     cleanup		 condition;	/* Used to set up cleanup handler. */

	dcl     (addr, rel, unspec)	 builtin;

	dcl     error_table_$invalid_state fixed bin (35) external;
	dcl     error_table_$force_unassign fixed bin (35) external;
	dcl     error_table_$resource_unknown fixed bin (35) external;

	dcl     access_operations_$rcp_unassign bit (36) aligned ext static;

	dcl     cu_$level_get	 entry (fixed bin);
	dcl     cu_$level_set	 entry (fixed bin);
	dcl     get_ring_		 entry returns (fixed bin);
	dcl     hcs_$wakeup		 entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
	dcl     rcp_control_	 entry (bit (36) aligned, bit (18) aligned, bit (18) aligned, char (*),
				 fixed bin (17), bit (36) aligned, fixed bin (35));
	dcl     rcp_detach_$force_detach entry (ptr);
	dcl     rcp_lock_$lock	 entry (ptr, fixed bin (35));
	dcl     rcp_lock_$unlock	 entry (ptr);
	dcl     rcp_pointers_$com_seg	 entry returns (ptr);

unassign_device: entry (arg_device_name, arg_ecode);

/*	This entry point implements the rcp_sys_$unassign_device entry point.
   *	We will call rcp_control_ to unassign the specified device.
   *	If the device is attached we will detach it.  We will free any RCS
   *	entries used by this device.
*/
	call SETUP;				/* Perform initialization. */
	on cleanup begin;				/* Cleanup if any trouble. */
		call CLEANUP;			/* Unlock lock and reset validation level. */
	     end;
	call cu_$level_set (get_ring_ ());		/* Set validation level to RCP level. */

	device_name = arg_device_name;		/* Copy device name argument. */

	call FREE_ENTRIES;				/* Clean up everything in RCS for device. */
	if ecode ^= 0
	then goto DEVICE_RETURN;

	detailed_operation.force = "1"b;

	call rcp_control_ (operation, volume_offset, device_offset,
	     device_name, error_count, process_id, ecode);

DEVICE_RETURN:
	call cu_$level_set (caller_level);
	arg_ecode = ecode;
	return;

/* 	*/
unassign_process: entry (arg_process_id, arg_ecode);

/*	This entry point implements the rcp_sys_$unassign_process entry point.
   *	This entry point will call rcp_initializer_ to unassign everything that
   *	is assigned to the specified process.  We will detach any attached
   *	devices and free all RCS entries.
*/
	call SETUP;
	on cleanup begin;
		call CLEANUP;
	     end;
	call cu_$level_set (get_ring_ ());

	process_id = arg_process_id;			/* Copy argument. */
	process_flag = "1"b;			/* Using process ID not device name. */

	call FREE_ENTRIES;				/* Clean up everything in RCS for process. */
	if ecode ^= 0
	then goto PROCESS_RETURN;

	detailed_operation.process = "1"b;
	call rcp_control_ (operation, volume_offset, device_offset,
	     device_name, error_count, process_id, ecode);
PROCESS_RETURN:
	call cu_$level_set (caller_level);
	arg_ecode = ecode;
	return;

/* 	*/
FREE_ENTRIES: procedure;

/*	This procedure will test all of the RCS entries.  It will
   *	look for entries that it should make free.
*/

	lock_flag = "1"b;				/* RCS now locked. */
	call rcp_lock_$lock (lock_info_ptr, ecode);
	if ecode ^= 0				/* Any trouble locking RCS? */
	then return;				/* Yes. */

	do i = 1 to rcs.num_entries;			/* Look at all existing RCS entries. */
	     rcse_ptr = addr (rcs.entry (i));		/* Get pointer to rcs entry. */
	     call FREE_ENTRY;			/* See if we should free this entry. */
	end;

	call rcp_lock_$unlock (lock_info_ptr);
	lock_flag = "0"b;				/* RCS no longer locked. */

     end FREE_ENTRIES;

/* 	*/
FREE_ENTRY: procedure;

/*	This procedure is called to see if we should free the specified RCS entry.
   *	We will not free it if it is already free or if it does not match the
   *	specified device name or process ID.  If this entry is an attachment entry
   *	that has actually been attached then we will detach it.
*/
	if rcse.free_off ^= "0"b			/* Is entry free? */
	then return;				/* Yes, nothing to do. */

	if process_flag				/* Are we looking for process IDs? */
	then if rcse.process_id ^= process_id
	     then return;				/* Yes, but we didn't find one that matched. */
	     else ;				/* Yes, and this one matches. */
	else if rcse.device_name ^= device_name
	then return;				/* No, device name, but no match. */

	rcse.state = 0;				/* Put the device in an invalid state. */
	if process_flag then
	     rcse.ecode = error_table_$invalid_state;	/* Note the invalid state. */
	else rcse.ecode = error_table_$force_unassign;

	if rcse.kind = 1				/* If attachment we must detach. */
	then call rcp_detach_$force_detach (rcse_ptr);

/*	We have found an entry that we want to make free.  We cannot just call
   *	rcp_rcse_$free because we already have RCS locked and because we are
   *	probably not running in the process that had assigned this entry.
   *	If we are deleting all entries of a process we will add this entry to
   *	the free list since we can assume that process' own entry lists are
   *	gone or are at least no longer valid.  However, if we are just deleting
   *	an entry for some device it is possible that this entry is still on a
   *	process list.  Changing the state of the entry is all that we should do.
*/
	if process_flag				/* Using a process ID? */
	then do;					/* Yes, free entry ourselves. */
		rcse.free_off = rcs.first_free_off;
		rcse.process_id = "0"b;
		rcse.state = 0;
		rcs.first_free_off = rel (rcse_ptr);
	     end;
	else do;					/* Send wakeup to cause process attach to fail. */
		unspec (bump_message) = unspec (BUMP_MESSAGE);
		call hcs_$wakeup (rcse.process_id, rcse.event_id, bump_message, ecode);
	     end;

     end FREE_ENTRY;

/* 	*/
SETUP: procedure;

/*	This procedure is called to set up the data we will need in
   *	the cleanup handler.
*/

	device_offset = ""b;
	process_flag = ""b;
	process_id = ""b;
	volume_offset = ""b;
	device_name = "";
	operation = access_operations_$rcp_unassign;
	ops_ptr = addr (addr (operation) -> encoded_access_op.detailed_operation);
	error_count = 0;

	rcs_ptr = rcp_pointers_$com_seg ();
	lock_info_ptr = addr (rcs.lock_info);		/* Needed to lock and unlock RCS. */
	lock_flag = "0"b;				/* Lock not locked yet. */

	call cu_$level_get (caller_level);		/* Get caller's validation level. */

     end SETUP;

CLEANUP: procedure;

/*	This procedure is called from the cleanup handlers.
   *	We must reset the validation level to the caller's level.
   *	If we now have RCS locked we must unlock it.
*/
	if lock_flag				/* Is RCS locked? */
	then call rcp_lock_$unlock (lock_info_ptr);

	call cu_$level_set (caller_level);

     end CLEANUP;

%include rcp_com_seg;
%page;
%include access_audit_encoded_op;
%page;
%include rcp_ops;

     end rcp_force_unassign_;




		    rcp_get_scratch_volume_.pl1     11/11/89  1110.3rew 11/11/89  0807.0       44379



/****^  ***********************************************************
        *                                                         *
        * 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(85-09-11,Farley), approve(85-09-11,MCR6979),
     audit(85-12-17,CLJones), install(86-03-21,MR12.0-1033):
     Add MCA support
                                                   END HISTORY COMMENTS */

rcp_get_scratch_volume_: proc (a_rcse_ptr, rsc_name, access, code);


/*	Modified Jan 1985 by Paul Farley to add device_type (8) "MCA". */
/*

   This procedure is called by RCP to get the name of a scratch volume from Resource Management.
   If Resource Management is not enabled, we will just return the old " " name and RW access.


*/

/*		PARAMETERS		*/


	dcl     a_rcse_ptr		 ptr;		/* Pointer to the RSCE of the volume in question. */
	dcl     access		 bit (3) aligned;	/* User's access to the reosurce. */
	dcl     code		 fixed bin (35);	/* Error code. */
	dcl     rsc_name		 char (*);	/* Name of the resource. */


/*		CONSTANTS			*/


	dcl     DEN_NAME		 (5) char (12) varying static internal options (constant) init (
				 ",den=200", ",den=556", ",den=800", ",den=1600", ",den=6250");
	dcl     RW		 bit (3) static internal options (constant) init ("101"b);


/*		AUTOMATIC STORAGE		*/


	dcl     attrs		 char (256) varying;
	dcl     i			 fixed bin;
	dcl     model_pic		 pic "zzz9";


/*		BUILTIN FUNTIONS		*/


	dcl     addr		 builtin;
	dcl     null		 builtin;
	dcl     size		 builtin;
	dcl     string		 builtin;


/*		ERROR CODES		*/


	dcl     error_table_$action_not_performed fixed bin (35) ext;


/*		ENTRIES CALLED		*/


	dcl     cv_rcp_attributes_$from_string_rel entry (char (*), (4) bit (72) aligned, char (*) varying, fixed bin (35));
	dcl     rcp_pointers_$com_seg	 entry () returns (ptr);
	dcl     rcp_pointers_$data	 entry () returns (ptr);
	dcl     rcprm_find_resource_$reserve entry (ptr, char (*), ptr, fixed bin (35));

%include rcp_data;

%include rcp_com_seg;

%include resource_control_desc;

%include rcp_resource_types;

/*

   First, get things set up and ready to go.

*/


	rcse_ptr = a_rcse_ptr;
	rsc_name = "";				/* Good enough for now. */
	access = RW;				/* " */
	code = 0;					/* No error. */


	rcpd_ptr = rcp_pointers_$data ();
	rcs_ptr = rcp_pointers_$com_seg ();


/*

   Now, if Resource Management is not enabled, we will simply return.

*/


	if ^rcpd.modes.resource_mgmt_enabled then return;


/*

   Resource Management must be queried.  Ask him for a system resource of the type specified.

*/


	Resource_count = 1;

	begin;

	     dcl	   garbage	      (size (resource_descriptions)) bit (36);

	     string (garbage) = "0"b;

	     resource_desc_ptr = addr (garbage);
	     resource_descriptions.version_no = resource_desc_version_1;
	     resource_descriptions.n_items = 1;
	     resource_descriptions.item (1).type = VOLUME_TYPE (rcse.dtypex);
	     goto MAKE_ATTRS (rcse.dtypex);


MAKE_ATTRS (1):					/* TAPE VOL */

	     if rcse.qualifiers (1) = 9
	     then attrs = "track=9";
	     else attrs = "track=7";

	     do i = 1 to hbound (DEN_NAME, 1);
		if substr (unspec (rcse.qualifiers (2)), i, 1)
		then attrs = attrs || DEN_NAME (i);
	     end;
	     goto MADE_ATTRS;


MAKE_ATTRS (2):					/* DISK VOL */

	     model_pic = rcse.model;
	     attrs = "model=" || ltrim (model_pic) || ",use=io";
	     goto MADE_ATTRS;


MAKE_ATTRS (3):					/* NOT USED */
MAKE_ATTRS (4):					/* NOT USED */
MAKE_ATTRS (5):					/* NOT USED */
MAKE_ATTRS (6):					/* NOT USED */
MAKE_ATTRS (7):					/* NOT USED */
MAKE_ATTRS (8):					/* NOT USED */

	     attrs = "";


MADE_ATTRS:

	     if attrs = ""
	     then resource_descriptions.item (1).desired_attributes (*) = "0"b;
	     else do;
		     call cv_rcp_attributes_$from_string_rel ((VOLUME_TYPE (rcse.dtypex)),
			resource_descriptions.item (1).desired_attributes (*), attrs, code);
		     if code ^= 0
		     then return;
		     resource_descriptions.item (1).given.desired_attributes = "1"b;
		end;

	     call rcprm_find_resource_$reserve (resource_desc_ptr, (rcs.acs_directory), null (), code);
	     if code = error_table_$action_not_performed then
		code = resource_descriptions.item (1).status_code;
	     if code ^= 0 then return;

	     rsc_name = resource_descriptions.item (1).name;
	     access = resource_descriptions.item (1).rew;

	end;

	return;


     end rcp_get_scratch_volume_;




		    rcp_ioi_attach_.pl1             11/11/89  1110.3r   11/11/89  0805.5       19476



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


rcp_ioi_attach_:  procedure (arg_rcse_ptr, arg_ecode);

/*	This program is an internal RCP interface.
*	Created on 07/14/75 by Bill Silver.
*
*	This program will call IOI to attach the device specified in the RCSE.
*	If the attachment is successful an attachment message will be output
*	to the operator.  If the caller has specified a comment, a note message
*	will also be output to the operator.
*/

dcl	arg_ecode		fixed bin(35);	/* (O) Return error_table_ code. */
dcl	arg_rcse_ptr	ptr;		/* (I) Pointer to the RCSE that specifies the device. */

dcl	ecode		fixed bin(35);	/* error_table_ code. */

dcl	admin_gate_$ioi_attach	entry  (fixed bin, char(*) aligned, fixed bin(71), bit(1) aligned, fixed bin(35));
dcl	admin_gate_$syserr		entry  options(variable);
dcl	rcp_comment_		entry  (ptr);
/*	*/
%include rcp_com_seg;
/*	*/
	rcse_ptr = arg_rcse_ptr;		/* Copy argument. */

	call admin_gate_$ioi_attach (rcse.ioi_index, rcse.device_name, rcse.event_id, (rcse.flags.priv), ecode);
	arg_ecode = ecode;
	if   ecode ^= 0			/* If attachment failed don't output messages. */
	     then return;

	call admin_gate_$syserr (0, "RCP: Attached ^a for ^a", rcse.device_name, rcse.group_id);
	call rcp_comment_ (rcse_ptr);		/* Type out any user comment. */


/* BEGIN MESSAGE DOCUMENTATION

Message:
RCP: Attached DEVICE for PERSON.PROJ.T

S:	$info

T:	$run

M:	The device DEVICE has been attached by the user process.

A:	$ignore


END MESSAGE DOCUMENTATION */

	end  rcp_ioi_attach_;




		    rcp_lock_.pl1                   11/11/89  1110.3r   11/11/89  0807.0       31338



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


rcp_lock_:  procedure;

/*	This program is an internal RCP interface.
*	Created on 12/07/74 by Bill Silver.
*
*	This program manages the locks that control RCPD and RCS.
*	It contains the following two entry points:
*	     1.	lock   -	Lock the segment.
*	     2.	unlock -	Unlock the segment.
*/

/*		ARGUMENT  DATA		*/

dcl	arg_ecode		fixed bin(35);	/* (O) error_table_ code. */
dcl	arg_lock_info_ptr	ptr;		/* (I) Pointer to lock info structure. */


/*		AUTOMATIC  DATA		*/

dcl	ecode		fixed bin(35);	/* error_table_ code. */
dcl	time_locked	fixed bin(71);	/* Length of time lock was locked. */
dcl	time_waiting	fixed bin(71);	/* Length of time waiting for lock. */


/*		EXTERNAL ENTRIES CALLED	*/

dcl	error_table_$invalid_lock_reset  fixed bin(35)  external;

dcl	admin_gate_$guaranteed_eligibility_off	entry  options(variable);
dcl	admin_gate_$guaranteed_eligibility_on	entry  options(variable);
dcl	rcp_set_lock_$meter_lock    entry  (bit(36) aligned,fixed bin,fixed bin(71),fixed bin(71),fixed bin(35));
dcl	rcp_set_lock_$meter_unlock  entry  (bit(36) aligned,fixed bin(71),fixed bin(71),fixed bin(35));
/*	*/
%include rcp_com_seg;
/*	*/
/*	This entry point is called to lock the specified lock.  Before locking we
*	must make sure that we will not lose eligibility while the lock is locked.
*	We will meter any time that we have to wait for the lock.  We will wait for
*	up to 2 minutes for the lock.  We will remember when the lock was locked
*	so we can calculate other meters at unlock time.
*/
lock:  entry  (arg_lock_info_ptr,arg_ecode);

	lock_info_ptr = arg_lock_info_ptr;	/* Get pointer to lock info structure. */

	call admin_gate_$guaranteed_eligibility_on();

	call rcp_set_lock_$meter_lock (lock_info.lock,120,lock_info.time_of_lock,time_waiting,ecode);
	if   (ecode ^= 0)  &		/* Any trouble locking? */
	     (ecode ^= error_table_$invalid_lock_reset)
	     then do;			/* Yes, lock not locked. */
		arg_ecode = ecode;		/* Abort lock. */
		call admin_gate_$guaranteed_eligibility_off();
		return;
	     end;

	lock_info.num_locks = lock_info.num_locks + 1;
	if   time_waiting ^= 0
	     then lock_info.num_lock_waits = lock_info.num_lock_waits + 1;
	lock_info.tot_wait_time = lock_info.tot_wait_time + time_waiting;

	arg_ecode = 0;
	return;
/*	*/
/*	This entry is called to unlock the specified lock.
*	After it is unlocked we must turn OFF the guaranteed eligibility.
*	We will compute the length of time the lock was locked.
*/
unlock:  entry  (arg_lock_info_ptr);

	lock_info_ptr = arg_lock_info_ptr;	/* Get pointer to lock info structure. */

	call rcp_set_lock_$meter_unlock (lock_info.lock,lock_info.time_of_lock,time_locked,ecode);

	call admin_gate_$guaranteed_eligibility_off();

	lock_info.tot_lock_time = lock_info.tot_lock_time + time_locked;

	end  rcp_lock_;




		    rcp_lv_.pl1                     11/11/89  1110.3rew 11/11/89  0805.5       87984



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


rcp_lv_: procedure;

/*	This program is an internal interface of RCP.
   *	Created on 04/08/76 by Bill Silver.
   *	Massively reworked on 09/13/76 by Bernard Greenberg for lv_request_.
   *
   *	This program is call to manage a per-process list of attached logical volumes.
   *	It has the following entry points:
   *	     1.  add_lv  -	Adds a logical volume to the list.
   *	     2.  del_lv  -  Deletes a logical volume from the list.
   *	     3.  check   - 	Returns lvid of attached lv.
   *	     4.  number  - 	Returns the number of attached lvs.
   *	     5.  copy    - 	Copies lv info.
*/

/*		ARGUMENTS		*/

dcl  arg_ecode fixed bin (35);			/*  (O)  error_table_ code. */
dcl  arg_event_id fixed bin (71);			/*  (I)  User-supplied event ID */
dcl  arg_lvid bit (36) aligned;			/* (I/O) Logical volume ID. */
dcl  arg_lv_name char (*);				/*  (I)  Logical volume name. */
dcl  arg_num_lvs fixed bin;				/*  (O)  Number of attached lvs. */
dcl  arg_rcp_id bit (36) aligned;			/* (I/O) RCP ID of this LV attachment. */
dcl  arg_rli_ptr ptr;				/*  (I)  Pointer to RLI structure. */
dcl  arg_statex fixed bin;				/*  (O)  State index. */


/*		AUTOMATIC DATA		*/

dcl  ecode fixed bin (35);				/* error_table_ code. */
dcl  event_id fixed bin (71);				/* User's event ID. */
dcl  lvid bit (36) aligned;				/* LV ID. */
dcl  lv_name char (32);				/* Name of lv. */
dcl  i fixed bin;
dcl  listx fixed bin;				/* LV array index. */
dcl  num_lvs fixed bin;				/* Number of attached lvs. */
dcl  rcp_id bit (36) aligned;				/* RCP ID for this LV attachment. */
dcl  statex fixed bin;
dcl  freex fixed bin;				/* Free index in lv_list search */


/*		BASED DATA		*/

dcl 1 based_rcp_id based aligned,			/* Overlay of RCP ID. */
   (2 id_count fixed bin (17),			/* Count make ID unique. */
    2 index fixed bin (17)) unal;			/* LV list index. */

/*		STATIC DATA		*/

dcl  rcp_id_count fixed bin internal static init (0);

dcl 1 lv_list (16) aligned internal static,		/* Per-process list of attached lvs. */
    2 volume_name char (32),				/* LV name. */
    2 lvatep ptr,					/* Identifier for lv_request_communicator_ */
    2 r0_accepted bit (1),				/* Called attach_lv. */
    2 lvid bit (36),				/* UID of lv. */
    2 rcp_id bit (36),				/* RCP ID for this LV attachment. */
    2 state_time fixed bin (71);			/* Time lv attached for process. */


/*		EXTERNAL ENTRIES CALLED	*/

dcl (addr, hbound) builtin;

dcl  error_table_$bad_index fixed bin (35) external;
dcl  error_table_$noalloc fixed bin (35) external;
dcl  error_table_$resource_assigned fixed bin (35) external;
dcl  error_table_$resource_unassigned fixed bin (35) external;

dcl  admin_gate_$attach_lv entry (bit (36) aligned, fixed bin (35));
dcl  admin_gate_$detach_lv entry (bit (36) aligned, fixed bin (35));
dcl  clock_ entry returns (fixed bin (71));
dcl  lv_request_communicator_$alloc_lvate entry (fixed bin (35)) returns (ptr);
dcl  lv_request_communicator_$abandon entry (ptr);
dcl  lv_request_communicator_$check entry (ptr, fixed bin, fixed bin (35));
dcl  lv_request_communicator_$intent_to_mount entry (ptr, char (*), fixed bin (71), fixed bin (35));
dcl  lv_request_communicator_$intent_to_detach entry (ptr, fixed bin (35));
						/* 	*/
%include rcp_list_info;
/* 	*/
add_lv:	entry (arg_lv_name, arg_lvid, arg_event_id, arg_rcp_id, arg_ecode);

/*	This entry will add the specified logical volume to the list of
   *	attached lvs.  The name and ID of this lv will be saved.
   *	An RCP ID will be generated that references this LV attachment.
   *	If valid, the lv_request_mechanism will be informed of the attachment.
*/

	lv_name = arg_lv_name;			/* Copy arguments. */
	lvid = arg_lvid;
	event_id = arg_event_id;
	rcp_id = "0"b;
	ecode = 0;

	freex = 0;				/* Initialize search through list. */
	do i = 1 to hbound (lv_list, 1);		/* Look at all possible entries. */

	     rcp_id = lv_list (i).rcp_id;		/* Make sure each entry is valid as it is considered. */
	     call CHECK_RCP_ID;			/* Get latest info. */

	     if lv_list (i).rcp_id = "0"b		/* Is this a free entry? */
	     then if freex = 0			/* Yes, is it the first free entry? */
		then freex = i;			/* Yes, remember this entry. */
		else;				/* No, we already have an entry. */
	     else if lv_list (i).volume_name = lv_name
	     then do;				/* Entry taken, and by this lv. */
		ecode = error_table_$resource_assigned;
		rcp_id = lv_list (i).rcp_id;		/* Return so check call can go. */
		goto ADD_LV_RETURN;
	     end;
	end;

	if freex = 0				/* Did we find a free entry? */
	then do;					/* No, all taken. */
	     ecode = error_table_$noalloc;
	     goto ADD_LV_RETURN;
	end;

	listx = freex;				/* First free is new one. */


	rcp_id_count = rcp_id_count + 1;		/* Found entry.  Gen new RCP ID. */
	addr (rcp_id) -> based_rcp_id.id_count = rcp_id_count;
	addr (rcp_id) -> based_rcp_id.index = listx;


	lv_list (listx).lvatep = lv_request_communicator_$alloc_lvate (ecode);
	if ecode ^= 0 then go to ADD_LV_RETURN;

	call lv_request_communicator_$intent_to_mount (lv_list (listx).lvatep, lv_name, event_id, ecode);
						/* Fill in entry, send message */
	if ecode ^= 0 then go to ADD_LV_RETURN;

	lv_list (listx).volume_name = lv_name;		/* Fill entry with lv info. */
	lv_list (listx).r0_accepted = "0"b;		/* Haven't checked into ring 0 yet. */
	lv_list (listx).lvid = lvid;
	lv_list (listx).state_time = clock_ ();
	lv_list (listx).rcp_id = rcp_id;		/* This marks entry as being used. */

ADD_LV_RETURN:
	arg_rcp_id = rcp_id;
	arg_ecode = ecode;
	return;
						/* 	*/
del_lv:	entry (arg_rcp_id, arg_ecode);

/*	This entry is called to remove an lv from the list of attached lvs.
*/

	rcp_id = arg_rcp_id;			/* Copy RCP ID argument. */

	call CHECK_RCP_ID;				/* Check that this RCP ID is valid. */
	if ecode = 0
	then do;
	     call lv_request_communicator_$intent_to_detach (lv_list (listx).lvatep, ecode);
	     lv_list (listx).rcp_id = "0"b;		/* free local entry */
	     ecode = 0;				/* Dont care */
	end;

	arg_ecode = ecode;
	return;








check:	entry (arg_rcp_id, arg_lvid, arg_statex, arg_ecode);

/*	This entry is called to check that the specified (by RCP ID) lv
   *	is really still attached.  If it is the ID of the lv will be returned.
*/

	rcp_id = arg_rcp_id;

	call CHECK_RCP_ID;				/* Check that this RCP ID is valid. */
	if ecode = 0
	then arg_lvid = lv_list (listx).lvid;		/* Get lv ID. */
	else arg_lvid = "0"b;

	if ecode = 0 & statex = 0 then if ^lv_list (listx).r0_accepted then do;
		call admin_gate_$attach_lv (lv_list (listx).lvid, ecode);
		if ecode = 0 then lv_list (listx).r0_accepted = "1"b;
	     end;

	arg_ecode = ecode;
	arg_statex = statex;
	return;
						/* 	*/
number:	entry (arg_num_lvs);

/*	This entry returns the current number of attached lvs.
*/
	num_lvs = 0;				/* Init. */

	do i = 1 to hbound (lv_list, 1);		/* Test all possible entries. */

	     rcp_id = lv_list (i).rcp_id;
	     call CHECK_RCP_ID;			/* Get latest info on validity. */

	     if lv_list (i).rcp_id ^= "0"b		/* Is this entry being used? */
	     then num_lvs = num_lvs + 1;		/* Yes, there is an attached lv here. */
	end;

	arg_num_lvs = num_lvs;
	return;







copy:	entry (arg_rli_ptr);

/*	This entry is called to fill in info about all attached lvs.
*/
	rli_ptr = arg_rli_ptr;			/* Get pointer to RLI structure. */

	rli.head.num_lv = hbound (lv_list, 1);		/* Set max number for now. */
	num_lvs = 0;				/* Init to count attached lvs. */

	do i = 1 to hbound (lv_list, 1);		/* Test all possible entries. */
	     rcp_id = lv_list (i).rcp_id;
	     call CHECK_RCP_ID;			/* Get latest info on validity. */

	     if lv_list (i).rcp_id ^= "0"b		/* Is this entry being used? */
	     then do;				/* Yes, copy info. */
		num_lvs = num_lvs + 1;		/* Up count. */
		lv_ptr = addr (rli.lvs (num_lvs));
		lv.volume_name = lv_list (i).volume_name;
		lv.state_time = lv_list (i).state_time;
		lv.rcp_id = lv_list (i).rcp_id;
	     end;
	end;

	rli.head.num_lv = num_lvs;			/* Set real count. */

	return;
						/* 	*/
CHECK_RCP_ID: procedure;

/*	This internal procedure is called to validate the RCP ID argument.
   *	If it is valid it will return the index to the lv_list entry that
   *	corresponds to the RCP ID.
*/

	     listx = addr (rcp_id) -> based_rcp_id.index; /* Get array index. */
	     if (listx = 0) |			/* Is index part of RCP ID valid? */
	     (listx > hbound (lv_list, 1))
	     then do;				/* No. */
		ecode = error_table_$bad_index;
		return;
	     end;

	     if lv_list (listx).rcp_id = rcp_id		/* Is this RCP ID valid? */
	     then ecode = 0;			/* Yes. */
	     else do;				/* Bad, bad */
		ecode = error_table_$resource_unassigned;
		return;
	     end;

	     call lv_request_communicator_$check (lv_list (listx).lvatep, statex, ecode);

	     if ecode ^= 0 then do;			/* Invalidate lv_list slot, abandon entry */
		if lv_list (listx).r0_accepted
		then call admin_gate_$detach_lv (lv_list (listx).lvid, (0));
						/* Get it out of ring 0. */
		call lv_request_communicator_$abandon (lv_list (listx).lvatep);
		lv_list (listx).rcp_id = "0"b;
	     end;

	end CHECK_RCP_ID;

     end rcp_lv_;




		    rcp_match_.pl1                  11/11/89  1110.3rew 11/11/89  0807.0       61479



/****^  ***********************************************************
        *                                                         *
        * 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(85-09-11,Farley), approve(85-09-11,MCR6979),
     audit(85-12-02,CLJones), install(86-03-21,MR12.0-1033):
     Add MCA support
                                                   END HISTORY COMMENTS */

rcp_match_: procedure;

/*	This program is an internal interface of RCP.
   *	Created on 01/29/75 by Bill Silver.
   *	Modified Jan 1985 by Paul Farley to add device_type (8) "MCA".
   *
   *	This program is called to choose a device that is appropriate for assignment.
   *	It has the following entry points:
   *	     1.	match  -	Given device characteristics that we want to match, see if
   *			a specified test device does match these characteristics.
   *	     2.	select -	Given a list of devices that match the specified character-
   *			istics, select the best device to assign.
*/

/*		ARGUMENT  DATA		*/

	dcl     arg_match_list_ptr	 ptr;		/* (I) Pointer to a list of devices that match. */
	dcl     arg_match_ptr	 ptr;		/* (I/O) I => match,  O => select. */
	dcl     arg_num_match	 fixed bin;	/* (I) Number of devices in match list. */
	dcl     arg_test_ptr	 ptr;		/* (I) Pointer to a device to test. */
	dcl     arg_volume_name	 char (*);	/* (I) Volume to be used with assigned device. */


/*		AUTOMATIC  DATA		*/

	dcl     i			 fixed bin;
	dcl     low_time		 fixed bin (71);	/* Current earliest time. */
	dcl     match_density	 bit (4) aligned;	/* Density that we must match. */
	dcl     match_info_ptr	 ptr;		/* Pointer to info that we must match. */
	dcl     match_list_ptr	 ptr;		/* Pointer to a list of devices that match. */
	dcl     match_speed		 bit (3) aligned;	/* Speed that we must match. */
	dcl     num_match		 fixed bin;	/* Number of devices in match list. */
	dcl     test_density	 bit (4) aligned;	/* Density of device we are testing. */
	dcl     test_info_ptr	 ptr;		/* Pointer to info about device we are testing. */
	dcl     test_speed		 bit (3) aligned;	/* Speed of device we are testing. */
	dcl     volume_name		 char (32);	/* Volume to be used with assigned device. */


/*		BASED  DATA		*/

	dcl     1 match_info	 based (match_info_ptr) like rcse aligned;

	dcl     1 test_info		 based (test_info_ptr) like rcse aligned;

	dcl     match_list		 (num_match) ptr based (match_list_ptr);

	dcl     based_density	 bit (4) aligned based;

	dcl     based_speed		 bit (3) aligned based;

/*	EXTERNAL ENTRIES CALLED	*/

	dcl     addr		 builtin;
	dcl     clock		 builtin;

%include rcp_com_seg;
/* 	*/
match: entry (arg_match_ptr, arg_test_ptr) returns (bit (1));

/*	This entry is called to test if a device matches the specified characteristics.
   *	If it does then we will return a value of "1"b.  If it does not match then
   *	we will return "0"b.  If a device characteristic is not specified then it is not
   *	used in determining whether or not the device matches.
*/
	match_info_ptr = arg_match_ptr;		/* Copy arguments. */
	test_info_ptr = arg_test_ptr;

	if match_info.device_name ^= " "		/* Not blank => looking for specific device. */
	then if match_info.device_name = test_info.device_name
	     then return ("1"b);			/* This is it. */
	     else return ("0"b);			/* No other testing necessary. */

	if match_info.model ^= 0			/* If model specified then test. */
	then if match_info.model ^= test_info.model
	     then return ("0"b);			/* Device model numbers don't match. */

	goto DTYPE (match_info.dtypex);		/* Match other characteristics based on device type. */


DTYPE (1):					/* TAPE */
	if match_info.qualifiers (1) ^= 0		/* If tracks specified then test. */
	then if match_info.qualifiers (1) ^= test_info.qualifiers (1)
	     then return ("0"b);			/* Track types do not match. */
	match_density = addr (match_info.qualifiers (2)) -> based_density;
	test_density = addr (test_info.qualifiers (2)) -> based_density;
	if (match_density & test_density) ^= match_density
	then return ("0"b);				/* Tape density does not match. */
	match_speed = addr (match_info.qualifiers (3)) -> based_speed;
	test_speed = addr (test_info.qualifiers (3)) -> based_speed;
	if (match_speed & test_speed) ^= match_speed
	then return ("0"b);				/* Tape speed does not match. */
	return ("1"b);				/* Everything that had to match did. */


DTYPE (4):					/* PRINTER */
	do i = 1 to match_info.num_qualifiers;		/* Test each qualifying characteristic. */
	     if match_info.qualifiers (i) ^= 0		/* If characteristic specified then test. */
	     then if match_info.qualifiers (i) ^= test_info.qualifiers (i)
		then return ("0"b);			/* No match. */
	end;
	return ("1"b);				/* Everything that had to match did. */


DTYPE (2):					/* DISK */
DTYPE (3):					/* CONSOLE */
DTYPE (5):					/* PUNCH */
DTYPE (6):					/* READER */
DTYPE (7):					/* SPECIAL */
DTYPE (8):					/* MCA */
	return ("1"b);				/* No characteristics => match. */
						/* 	*/
select: entry (arg_match_list_ptr, arg_num_match, arg_volume_name, arg_match_ptr);

/*	This entry is called to select the best device to assign from among
   *	a list of devices that match the assignment requirements.  If the
   *	assignment is to be made based upon a volume then if one of devices
   *	has that volume mounted we will choose that device.  Otherwise,
   *	we will choose the device that has been in its current state the
   *	longest.
*/
	match_list_ptr = arg_match_list_ptr;		/* Copy arguments. */
	num_match = arg_num_match;
	volume_name = arg_volume_name;

	low_time = clock () + 1;			/* Start with latest possible time. */

	do i = 1 to num_match;			/* Test each device that matched. */
	     match_info_ptr = match_list (i);		/* Pointer to device info. */
	     if (volume_name ^= " ") & /* Are we looking for a volume? */
		(volume_name = match_info.volume_name)
	     then do;				/* Yes, and we found it.  Select this device. */
		     arg_match_ptr = match_info_ptr;
		     return;
		end;
	     if match_info.state_time < low_time	/* Has device been in this state longer? */
	     then do;				/* Yes, for now select this device. */
		     test_info_ptr = match_info_ptr;
		     low_time = match_info.state_time;
		end;
	end;

	arg_match_ptr = test_info_ptr;		/* No volume found. */

     end rcp_match_;




		    rcp_match_user_name_.pl1        11/11/89  1110.3rew 11/11/89  0807.0       31401



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


rcp_match_user_name_: proc (user_name, match_name) returns (bit (1));


/*

   This procedure is called by RCP to see if a group_id matches a match string
   which is a group_id with star components.

   For example User.Proj.a would match User.*.* or User but not User.Proj.m


   Written 06/01/78 by Michael R. Jordan

*/

dcl  addr builtin;
dcl  index builtin;
dcl  length builtin;
dcl  match_name char (32) aligned;			/* Name in the RCPD. */
dcl  substr builtin;
dcl  user_name char (32) aligned;			/* Name of the user. */

dcl 1 user aligned,
    2 person char (32),				/* Person_id */
    2 project char (32),				/* Project_id */
    2 tag char (32);				/* Instance tag */
dcl 1 match like user;

/*

   If the strings match, the test succeeds.

*/


	if user_name = match_name then return ("1"b);


/*

   Well, we have to do some work.  First parse the two strings
   and then see if they match.  If so the test succeeds.

*/


	call PARSE (user_name, addr (user));
	call PARSE (match_name, addr (match));


/*

   Now test the structures returned.

*/


	if user.person ^= match.person then		/* Not the same person. */
	     if match.person ^= "*" then return ("0"b);	/* Nope! */

	if user.project ^= match.project then		/* Not the same project. */
	     if match.project ^= "*" then return ("0"b);

	if user.tag ^= match.tag then			/* Not the right tag. */
	     if match.tag ^= "*" then return ("0"b);


/*

   All matched in some way - succeed!

*/


	return ("1"b);

PARSE:	proc (s, st_ptr);


dcl  s char (*) aligned;				/* The string to parse. */
dcl  st_ptr ptr;					/* Ptr to the following structure... */


dcl  i fixed bin;					/* start of substring */
dcl  l fixed bin ;					/* length of substring */
dcl 1 st like user based (st_ptr);


/*

   start out with default values for the structure.

*/


	     st.person, st.project, st.tag = "*";


/*

   Now get the Person_id.

*/


	     l = index (s, ".")-1;			/* length of substring */
	     if l < 0 then do;			/* this is the last substring */
		st.person = s;
		return;
	     end;

	     if l > 0 then				/* the substring is not null */
		st.person = substr (s, 1, l);		/* so use it */

	     i = l+2;				/* update start of next substring */
	     if i > length (s) then return;		/* if there's no more, quit */


	     l = index (substr (s, i), ".")-1;		/* length of substring */
	     if l < 0 then do;			/* this is the last substring */
		st.project = substr (s, i);
		return;
	     end;

	     if l > 0 then				/* the substring is not null */
		st.project = substr (s, i, l);	/* so use it */

	     i = i+l+1;				/* update start of next substring */
	     if i > length (s) then return;		/* no more data */


	     st.tag = substr (s, i);			/* last substring */


	     return;


	end PARSE;


     end rcp_match_user_name_;




		    rcp_merge_modes.pl1             11/11/89  1110.3r w 11/11/89  0804.6       13878



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */
/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_merge_modes:
     procedure (a_mode1, a_mode2, a_code) returns (bit (3));

/*     This program is an internal interface of RCP.
   *     Created 841025 by Maria M. Pozzo
   *
   *     This program implements the RCP internal subroutine that
   *     will merge two raw modes together to determine an effective
   *     mode.
*/

/*                    ARGUMENT DATA                            */
dcl	a_mode1		   bit (3);		/* (I) Raw mode */
dcl	a_mode2		   bit (3);		/* (I) Raw mode */
dcl	a_code		   fixed bin (35);		/* (O) Error code */


/*                    INTERNAL STATIC DATA                     */

dcl	result_mode	   bit (3);		/* (O) Resulting mode */

/*                    EXTERNAL STATIC DATA                     */

dcl	error_table_$resource_bad_access
			   fixed bin (35) ext static;

	result_mode = a_mode1 & a_mode2;
	if result_mode = N_ACCESS then
	     a_code = error_table_$resource_bad_access;

	return (result_mode);
%page;
%include access_mode_values;

     end rcp_merge_modes;




		    rcp_message_.pl1                11/11/89  1110.3rew 11/11/89  0805.9       52839



/****^  ***********************************************************
        *                                                         *
        * 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-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
     Correct error message documentation.
                                                   END HISTORY COMMENTS */


rcp_message_:  procedure;

/*	This program implements the RCP message entry points.
*	Created on 04/25/75 by Bill Silver.
*
*	This program has the following entry points:
*	     1. 	priv  -	Allows privileged users to send messages to the operator
*			that involve an attached device.
*	     2.	tape  -	Generates a tape mount message.
*/

dcl	arg_comment	char(*);		/* (I) Privileged comment. */
dcl	arg_ecode		fixed bin(35);	/* (O) error_table_ code. */
dcl	arg_rcp_id	bit(36) aligned;	/* (I) RCP ID. */
dcl	arg_volume_name	char(*);		/* (I) Name of reel to be mounted. */
dcl	arg_ring_flag	bit(1);		/* (I) ON => mount with write ring. */

dcl	caller_level	fixed bin;	/* Caller's validation level. */
dcl	ecode		fixed bin(35);	/* error_table_ code. */
dcl	rcp_id		bit(36) aligned;	/* RCP ID. */
dcl	volume_name	char(32)  aligned;	/* Tape reel to be mounted. */
dcl	ring_comment	char(8);		/* "with" or "without" ring. */

dcl	cleanup		condition;	/* Used to set up cleanup handler. */

dcl     (	error_table_$invalid_state,
	error_table_$no_operation )  fixed bin(35)  external;

dcl	admin_gate_$syserr	entry  options(variable);
dcl	cu_$level_get	entry  (fixed bin);
dcl	cu_$level_set	entry  (fixed bin);
dcl	get_ring_		entry  returns(fixed bin);
dcl	rcp_comment_	entry  (ptr);
dcl	rcp_validate_	entry  (bit(36) aligned, fixed bin, ptr, fixed bin(35));
/*	*/
%include rcp_com_seg;
/*	*/
priv:  entry  (arg_rcp_id, arg_comment, arg_ecode);

/*	This entry point is called by privileged users in order to display a
*	comment to the operator.  The comment should deal with an attached device.
*/
	call cu_$level_get (caller_level);	/* Get caller's validation level. */
	on   cleanup  begin;		/* Cleanup if any trouble. */
	     call cu_$level_set (caller_level);	/* Reset validation level. */
	end;
	call cu_$level_set (get_ring_());	/* Set validation level to RCP level. */

	rcp_id = arg_rcp_id;		/* Get RCP ID. */
	call rcp_validate_ (rcp_id, caller_level, rcse_ptr, ecode);
	if   ecode ^= 0			/* Is RCP ID valid? */
	     then goto PRIV_RETURN;		/* No. */

	if   (rcse.kind ^= 1)  |		/* Is this an attachment? */
	     (^rcse.flags.priv)		/* and was device attached with privilege? */
	     then do;			/* No, don't display the comment. */
		ecode = error_table_$no_operation;
		goto PRIV_RETURN;
	     end;

	rcse.caller_comment = arg_comment;	/* Copy caller's comment. */
	call rcp_comment_ (rcse_ptr);		/* Now go display this comment. */

PRIV_RETURN:
	call cu_$level_set (caller_level);	/* Reset caller's validation level. */
	arg_ecode = ecode;
	return;
/*	*/
tape:  entry  (arg_rcp_id, arg_volume_name, arg_ring_flag, arg_ecode);

/*	This entry point is called to display a tape mount message to the
*	operator.  This is a temporary feature of RCP that will be deleted
*	when all callers of tdcm_ stop calling tdcm_$tdcm_message more
*	than once.
*/
	call cu_$level_get (caller_level);	/* Get caller's validation level. */
	on   cleanup  begin;		/* Cleanup if any trouble. */
	     call cu_$level_set (caller_level);	/* Reset validation level. */
	end;
	call cu_$level_set (get_ring_());	/* Set validation level to RCP level. */

	rcp_id = arg_rcp_id;		/* Copy arguments. */
	volume_name = arg_volume_name;
	if   arg_ring_flag			/* Are we mounting with or without a write ring? */
	     then ring_comment = "with";
	     else ring_comment = "without";

	call rcp_validate_ (rcp_id, caller_level, rcse_ptr, ecode);
	if   ecode ^= 0			/* Does caller have a right to this device? */
	     then goto TAPE_RETURN;		/* No, something wrong. */

	if   rcse.dtypex ^= 1		/* Is this a tape device? */
	     then do;			/* No. */
		ecode = error_table_$no_operation;
		goto TAPE_RETURN;
	     end;

	if   (rcse.kind ^= 1)  |		/* Is tape attached? */
	     (rcse.state ^= 5)		/* And is attachment completed? */
	     then do;			/* No. */
		ecode = error_table_$invalid_state;
		goto TAPE_RETURN;
	     end;

	rcse.volume_name = volume_name;	/* Save this volume name. */
	call admin_gate_$syserr (3, "RCP: Mount Reel ^a ^a ring on ^a for ^a (switching volumes).",
			     volume_name, ring_comment, rcse.device_name, rcse.group_id);

TAPE_RETURN:
	call cu_$level_set (caller_level);	/* Reset to caller's validation level. */
	arg_ecode = ecode;


/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Mount Reel REELID with(out) ring on DRIVE for PERSON.PROJ.T (switching volumes).

   S:	$beep

   T:	$run

   M:	A user process has requested the mounting of
   tape reel REELID on drive DRIVE.

   A:	Locate the requested reel.
   Check to make sure that the user PERSON.PROJ is allowed to use the reel.
   Insert or remove a write ring as specified.
   Mount the reel on the specified drive.

   If the reel cannot be mounted, either because it
   cannot be located,
   access is incorrect,
   or the drive is down,
   use the "x deny" function to reject the mount request.


END MESSAGE DOCUMENTATION */

	end  rcp_message_;




		    rcp_mount_timer_.pl1            11/11/89  1110.3rew 11/11/89  0807.0       89811



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

/* format: off */

rcp_mount_timer_: procedure;

/*	This program implements the RCP mount timer mechanism.
   *	Created on 11/02/76 by Bill Silver.
   *	$account_init by B. Greenberg 8/2/77
*/


/****^  HISTORY COMMENTS:
  1) change(87-02-10,Farley), approve(87-04-14,MCR7652),
     audit(87-04-15,Lippard), install(87-04-28,MR12.1-1028):
     Changed to attempt to locate the attachment RCSE for the device and if
     found call rcp_comment_ to possibly display the user comment that was
     displayed with the first mount message.
                                                   END HISTORY COMMENTS */


/*	This program has the following entry points:
   *	     1.	init   -	called by a system process through the rcp_sys_ gate.
   *			It initializes the mount timer mechanism.
   *	     2. 	check  -	called by the system process that initialized the mount timer.
   *			It is called through the rcp_sys_ gate.  It checks to see
   *			if a mount is pending for the specified drive.  If a mount is
   *			pending the operator is told to check on this mount.
   *	     3.	set    -	an internal interface called by rcp_tape_ and rcp_disk_.
   *			It turns ON the mount pending flag for a specified drive
   *			and signals the system process that will check on this mount.
   *	     4.	reset  -	an internal interface called by rcp_tape_ and rcp_disk_.
   *			It turns OFF the mount pending flag for a specified drive.
   5.	account_init - like $init.  Called through rcp_sys_ to set up
   accounting channel/PID. Here for convenience.
*/

/*		ARGUMENTS			*/

dcl  arg_device_off bit (18) aligned;			/* (I) RCPD device entry offset. */
dcl  arg_ecode fixed bin (35);			/* (O) error_table_ code. */
dcl  arg_ev_chan fixed bin (71);			/* (I) Mount timer IPC event channel. */
dcl  arg_recheck_flag bit (1) aligned;			/* (O) ON => check this mount again. */
dcl  arg_write_flag bit (1) aligned;			/* (I) ON => mounting for writing. */


/*		AUTOMATIC DATA		*/

dcl  caller_level fixed bin;				/* Caller's validation level. */
dcl  device_off bit (18) aligned;			/* RCPD device entry offset. */
dcl  ecode fixed bin (35);
dcl  message_buffer fixed bin (71);			/* Holds message send to system process. */
dcl  message_ptr ptr;				/* Pointer for based message structure. */
dcl  recheck_flag bit (1);
dcl  rcsx fixed bin;				/* RCS index */


/*		BASED DATA		*/

dcl 1 message based (message_ptr) aligned,		/* Mount timer message. */
    2 key char (4),					/* Must be "rcmt". */
   (2 device_off bit (18),				/* RCPD device entry offset. */
    2 mbz bit (18)) unal;


/*		INTERNAL STATIC DATA	*/

dcl  save_pid bit (36) aligned internal static init ("0"b);


/*		EXTERNAL DATA		*/

dcl (addr, fixed, mod, ptr, rel, size) builtin;

dcl  error_table_$bad_index fixed bin (35) external;
dcl  error_table_$bad_processid fixed bin (35) external;

dcl  admin_gate_$syserr entry options (variable);
dcl  cu_$level_get entry (fixed bin);
dcl  cu_$level_set entry (fixed bin);
dcl  get_process_id_ entry returns (bit (36) aligned);
dcl  get_ring_ entry returns (fixed bin);
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  rcp_comment_ entry (ptr);
dcl  rcp_pointers_$com_seg entry returns (ptr);
dcl  rcp_pointers_$data entry returns (ptr);
%page;%include rcp_data;
%page;%include rcp_com_seg;
%page;
init:	entry (arg_ev_chan, arg_ecode);

/*	This entry point is called by the system process that will handle
   *	the mount timer wakeups.  This entry just has to save the process
   *	ID of this process and the IPC event channel used for the mount timer
   *	wakeups.
*/
	call cu_$level_get (caller_level);		/* Save caller's validation level. */
	call cu_$level_set (get_ring_ ());		/* Set RCP's validation level. */

	rcpd_ptr = rcp_pointers_$data ();		/* Get a pointer to RCP_DATA. */

	rcpd.mtimer_chan = arg_ev_chan;		/* Save event channel and PID. */
	rcpd.mtimer_pid = get_process_id_ ();
	save_pid = rcpd.mtimer_pid;			/* Save process ID. */

	arg_ecode = 0;
	call cu_$level_set (caller_level);		/* Reset caller's validation level. */
	return;
%page;
account_init: entry (arg_ev_chan, arg_ecode);

/*	This entry point is called by the system process that will handle
   *	the accounting wakeups.  This entry just has to save the process ID
   *	of this process and the IPC event channel used for the accounting wakeups.
   *	It is in this program simply because of its similarity to the $init
   *	entry above: a convenience.
*/

	call cu_$level_get (caller_level);		/* Save/restor validation levels */
	call cu_$level_set (get_ring_ ());

	rcpd_ptr = rcp_pointers_$data ();		/* Get a pointer to RCP_DATA. */

	rcpd.accounting_chan = arg_ev_chan;		/* Copy params. */
	rcpd.accounting_pid = get_process_id_ ();

	arg_ecode = 0;
	call cu_$level_set (caller_level);
	return;
%page;
check:	entry (arg_device_off, arg_recheck_flag, arg_ecode);

/*	This entry point is called by the system process that is handling
   *	mount timer wakeups.  It passes in the RCPD device entry offset of
   *	the drive that it wants to check.  This entry  will check to see if
   *	a mount is now pending for this drive.  If so, a message will be sent
   *	to the system operator asking that this mount be checked.  The system
   *	process will be told to check on this mount again.
*/
	call cu_$level_get (caller_level);		/* Save callers validation level. */
	call cu_$level_set (get_ring_ ());		/* Set RCP validation level. */

	rcpd_ptr = rcp_pointers_$data ();		/* Get pointer to RCPD. */
	device_off = arg_device_off;			/* Copy argument. */

	ecode = 0;				/* Initialize variables. */
	recheck_flag = "1"b;

	if rcpd.mtimer_pid = "0"b			/* Have we been initialized yet? */
	then goto CHECK_RETURN;			/* No, just return. */

	if rcpd.mtimer_pid ^= save_pid		/* Caller must be process that initialized. */
	then do;					/* But it isn't. */
	     ecode = error_table_$bad_processid;
	     goto CHECK_RETURN;
	end;

/* Validate device entry offset. */
	if (device_off < rel (addr (rcpd.device))) |
	(device_off >= rel (addr (rcpd.volume))) |
	(mod ((fixed (device_off, 18) - fixed (rel (addr (rcpd.device)), 18)), size (device)) ^= 0)
	then do;					/* Offset not for a real entry. */
	     ecode = error_table_$bad_index;
	     goto CHECK_RETURN;
	end;

	device_ptr = ptr (rcpd_ptr, device_off);	/* Ok now to get ptr to device entry. */

	if device.dtypex > 2			/* Device must be a tape or disk drive. */
	then do;					/* No, it is some other type of device. */
	     ecode = error_table_$bad_index;
	     goto CHECK_RETURN;;
	end;

	recheck_flag = device.flags.mounting;		/* ON => a mount is pending. */
	if recheck_flag then do;			/* Is there a mount pending? */
	     call admin_gate_$syserr (3, "RCP: Check Mount of ^[scratch^s^;^a^]^[ for writing^] on ^a for ^a",
		(device.volume_name = ""), device.volume_name, device.flags.writing, device.device_name, device.group_id);

	     rcs_ptr = rcp_pointers_$com_seg ();

	     do rcsx = 1 to rcs.num_entries;
		rcse_ptr = addr (rcs.entry (rcsx));

		if rcse.state ^= 0 then		/* not free */
		     if rcse.kind = 1 then		/* attach entry */
			if rcse.device_name = device.device_name then do;
						/* correct device */
			     call rcp_comment_ (rcse_ptr); /* Type caller's comment. */
			     goto CHECK_RETURN;
			end;
	     end;
	end;

CHECK_RETURN:
	arg_recheck_flag = recheck_flag;		/* Return arguments. */
	arg_ecode = ecode;
	call cu_$level_set (caller_level);		/* Reset validation level. */
	return;
%page;
set:	entry (arg_device_off, arg_write_flag, arg_ecode);

/*	This entry point is called by RCP within the mounting process.
   *	The mount pending flag is turned ON for the specified device.
   *	A wakeup is sent to the mount timer process.
*/
	rcpd_ptr = rcp_pointers_$data ();		/* Get pointer to RCPD. */
	device_off = arg_device_off;			/* Get RCPD device entry offset. */
	device_ptr = ptr (rcpd_ptr, device_off);	/* Now get pointer to device entry. */

	if rcpd.mtimer_chan = 0			/* Is mount timer process there? */
	then do;					/* No, nothing to do. */
	     arg_ecode = 0;
	     return;
	end;

	device.flags.writing = arg_write_flag;		/* Remember if mounting for writing. */
	device.flags.mounting = "1"b;			/* Turn ON mount pending flag. */

	message_ptr = addr (message_buffer);		/* Set up mount timer message. */
	message.key = "rcmt";			/* Name of message. */
	message.device_off = device_off;		/* RCPD devce entry offset. */
	message.mbz = "0"b;

	call hcs_$wakeup (rcpd.mtimer_pid, rcpd.mtimer_chan, message_buffer, ecode);

	arg_ecode = ecode;
	return;
%page;
reset:	entry (arg_device_off, arg_ecode);

/*	This entry is called by RCP within the mounting process to turn OFF
   *	the mount pending flag.
*/

	rcpd_ptr = rcp_pointers_$data ();		/* Get pointer to RCPD. */
	device_ptr = ptr (rcpd_ptr, arg_device_off);

	device.flags.mounting = "0"b;			/* Mount no longer pending. */

	arg_ecode = 0;
	return;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Check Mount of REELID {for writing} on DRIVE for PERSON.PROJ.T

   S:	$beep

   T:	$run

   M:	The request to mount tape reel REELID has been unsatisfied for over 4 minutes.

   A:	Mount the reel or use "x deny" to inform the user that the reel cannot be mounted.


   END MESSAGE DOCUMENTATION */

     end rcp_mount_timer_;




		    rcp_operation_access.pl1        11/11/89  1110.3rew 11/11/89  0807.0       76437



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-06-08,Rauschelbach), approve(87-06-26,MCR7713),
     audit(87-07-08,Farley), install(87-07-15,MR12.1-1041):
     A check for access when changing potential attributes was added.  A fix to
     make the clear_resource command work was added.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_operation_access:
     procedure (a_operation, a_resource_type, a_rm_on, a_effmode, a_error_code);

/*     This program determines if the subject has enough access to
   *     the object to perform the requested RCP operation.
   *     Created 841109 by Maria M. Pozzo
   *
*/

/*                    ARGUMENT DATA                           */

dcl	a_operation	   bit (36) aligned;	/* (I) Requested RCP operation */
dcl	a_resource_type	   char (32);		/* (I) Resource type for requested operation */
dcl	a_rm_on		   bit (1);		/* (I) Resource Management enabled */
dcl	a_effmode		   bit (3);		/* (I/O) Current effective mode of the subject to the object(I) - resultant mode (O) */
dcl	a_error_code	   fixed bin (35);		/* (O) Error code */

/*                   AUTOMATIC DATA                           */

dcl	is_volume		   bit (1);
dcl	rm_on		   bit (1);		/* Resource management enabled */
dcl	effmode		   bit (3);		/* Subjects access to object depending on operation */
dcl	operation		   bit (36) aligned;
dcl	base_op		   bit (36) aligned;

dcl	resource_type	   char (32);		/* Resource type */

dcl	error_code	   fixed bin (35);		/* Internal error code */

dcl	operation_ptr	   ptr;

dcl	1 en_access_op	   like encoded_access_op based (operation_ptr) aligned;

dcl	addr		   builtin;

/*                       EXTERNAL ENTRIES             */

dcl	error_table_$insufficient_access
			   fixed bin (35) external;
dcl	error_table_$unsupported_operation
			   fixed bin (35) external;
dcl	access_operations_$rcp_deregister
			   bit (36) aligned external;
dcl	access_operations_$rcp_release
			   bit (36) aligned external;
dcl	access_operations_$rcp_reserve
			   bit (36) aligned external;
dcl	access_operations_$rcp_preload
			   bit (36) aligned external;
dcl	access_operations_$rcp_assign_read
			   bit (36) aligned external;
dcl	access_operations_$rcp_assign_write
			   bit (36) aligned external;
dcl	access_operations_$rcp_status
			   bit (36) aligned external;
dcl	access_operations_$rcp_set
			   bit (36) aligned external;
dcl	access_operations_$rcp_set_access
			   bit (36) aligned external;
dcl	access_operations_$rcp_clear
			   bit (36) aligned external;
dcl	access_operations_$rcp_delete_device
			   bit (36) aligned external;
dcl	access_operations_$rcp_add_device
			   bit (36) aligned external;

dcl	resource_info_$get_type
			   entry (char (*), bit (1), fixed bin (35));

/* Copy input arguments */

	operation = a_operation;
	base_op = basic_operation (operation);
	addr (base_op) -> encoded_access_op.detailed_operation = 0;
	operation_ptr = addr (operation);
	resource_type = a_resource_type;
	rm_on = a_rm_on;
	effmode = a_effmode;

/* Initialize local variables */

	error_code = 0;
	call resource_info_$get_type (resource_type, is_volume, error_code);
	ops_ptr = addr (en_access_op.detailed_operation);

/*  Is it a volume - most operations require R or RW to volumes */

	if is_volume then do;

/*  Need at least R to reserve a volume. */
/*  Need R to assign a volume for reading, need R to preload a volume. */

	     if base_op = access_operations_$rcp_reserve | base_op = access_operations_$rcp_assign_read
		| base_op = access_operations_$rcp_preload then do;
		call require_access (R_ACCESS);
		goto MAIN_RETURN;
	     end;

/*  Need at least RW to assign a volume for writing */

	     else if base_op = access_operations_$rcp_assign_write then do;
		call require_access (RW_ACCESS);
		goto MAIN_RETURN;
	     end;

	end;

	else do;

/* Need at least RW to reserve a device */
/* Need at least RW to assign a device */
/* Need at least RW to preload a device */
/* Need R to add or delete a device, this is a privileged operation. */

	     if base_op = access_operations_$rcp_reserve | base_op = access_operations_$rcp_assign_write
		| base_op = access_operations_$rcp_preload then do;
		call require_access (RW_ACCESS);
		goto MAIN_RETURN;
	     end;
	     else if base_op = access_operations_$rcp_delete_device | base_op = access_operations_$rcp_add_device
	     then do;
		call require_access (R_ACCESS);
		goto MAIN_RETURN;
	     end;

	end;

/*  The following operations are not resource-type specific. */

/*  SET_ACCESS */
/*  There are two kinds of set_access operations.  */
/*  The first type is the setting of access_class_range or */
/*  the potential access_class_range.  The call must have been */
/*  made through a privileged gate and have REW access. The second */
/*  type is setting the acs_path.  The caller either 1) must be the */
/*  resource owner and have REW access, or 2) have made the call through */
/*  a privileged gate and have REW access. */

	if base_op = access_operations_$rcp_set_access then do;
	     if detailed_operation.potential_aim_range | detailed_operation.aim_range then
		if detailed_operation.priv_gate_call then
		     call require_access (REW_ACCESS);
		else error_code = error_table_$insufficient_access;
	     else if detailed_operation.acs_path then
		if detailed_operation.owner | detailed_operation.priv_gate_call then
		     call require_access (REW_ACCESS);
		else error_code = error_table_$insufficient_access;
	end;

/* SET */
/* There are several other types of Set operations.  */
/* Setting of the comment requires E and therefore REW access */
/* Setting of release_lock, lock, location, or charge_type all */
/* require the call be made through a privileged gate and the */
/* user have E and therefore REW access.  All other sets require */
/* RW access. */


	else if base_op = access_operations_$rcp_set then do;
	     if detailed_operation.comment then
		call require_access (REW_ACCESS);
	     else if detailed_operation.release_lock | detailed_operation.usage_lock | detailed_operation.location
		| detailed_operation.charge_type | detailed_operation.potential_attributes then
		if detailed_operation.priv_gate_call then
		     call require_access (REW_ACCESS);
		else error_code = error_table_$insufficient_access;
	     else call require_access (RW_ACCESS);
	end;

/* RELEASE */
/* This operation requires 1) the user be the resource owner */
/* and have REW access OR 2) the call be made through a privileged gate */
/* and the user have REW. */

	else if base_op = access_operations_$rcp_release then do;
	     if detailed_operation.owner | detailed_operation.priv_gate_call then
		call require_access (REW_ACCESS);
	     else error_code = error_table_$insufficient_access;
	end;

/* DEREGISTER */
/* Must have REW to deregister or clear a resource. These are privileged operations. */

	else if base_op = access_operations_$rcp_deregister | base_op = access_operations_$rcp_clear then
	     call require_access (REW_ACCESS);

/* STATUS */
/* Only need R access to status a resource. */

	else if base_op = access_operations_$rcp_status then
	     call require_access (R_ACCESS);

	else error_code = error_table_$unsupported_operation;


MAIN_RETURN:
	if error_code ^= 0 then
	     a_effmode = "000"b;
	a_error_code = error_code;

	return;
%page;
require_access:
     proc (mode);

dcl	mode		   bit (3);

	if (effmode & mode) = mode then
	     return;
	else error_code = error_table_$insufficient_access;
	return;

     end require_access;
%page;
basic_operation:
     proc (oper) returns (bit (36) aligned);

dcl	oper		   bit (36) aligned;
dcl	return_arg	   bit (36) aligned;

	return_arg = oper;
	addr (return_arg) -> encoded_access_op.detailed_operation = 0;
	return (return_arg);

     end basic_operation;

%page;
%include access_audit_encoded_op;
%page;
%include access_mode_values;
%page;
%include rcp_ops;
%page;
%include rcp_resource_types;

     end rcp_operation_access;






		    rcp_pointers_.pl1               11/11/89  1110.3rew 11/11/89  0807.0       17892



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


rcp_pointers_:  procedure;

/*	This program is an internal interface of RCP.
*	Created on 07/31/75 by Bill Silver.
*
*	This program returns pointers to rcp_data or rcp_com_seg.
*	This program has the following entries:
*	     1.	data    -	Returns a pointer to rcp_data.
*	     2.	com_seg -	Returns a pointer to rcp_com_seg.
*/

dcl	ecode		fixed bin(35);

dcl	com_seg_init_flag	bit(1)		/* ON => com_seg_ptr initialized. */
	internal static	init ("0"b);
dcl	data_init_flag	bit(1)		/* ON => data_ptr initialized. */
	internal static	init ("0"b);

dcl	com_seg_ptr	ptr	internal static;
dcl	data_ptr		ptr	internal static;

dcl	hcs_$initiate	entry  (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35));
/*	*/
data:  	entry  returns (ptr);

	if   ^data_init_flag		/* Have we initiated pointer to rcp_data? */
	     then do;			/* No. */
		call hcs_$initiate (">system_library_1", "rcp_data", "", 0, 0, data_ptr, ecode);
		data_init_flag = "1"b;
	     end;

	return (data_ptr);



com_seg:	entry  returns (ptr);

	if   ^com_seg_init_flag		/* Have we initiated pointer to rcp_com_seg? */
	     then do;			/* No. */
		call hcs_$initiate (">system_library_1", "rcp_com_seg", "", 0, 0, com_seg_ptr, ecode);
		com_seg_init_flag = "1"b;
	     end;

	return (com_seg_ptr);


	end  rcp_pointers_;




		    rcp_pre_claim_.pl1              11/11/89  1110.3rew 11/11/89  0806.7       60228



/****^  ***********************************************************
        *                                                         *
        * 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-25,Rauschelbach), approve(87-06-29,MCR7736),
     audit(87-07-21,Farley), install(87-08-06,MR12.1-1063):
     System error message documentation was added.
                                                   END HISTORY COMMENTS */


rcp_pre_claim_:
     proc (a_reservation_id, a_group_id, a_process_id, a_code);

/*
   *       This subroutine will implement the privileged pre-claiming of reservations.
   *  This function will only be used by the absentee manager in the
   *  initializer process.
   *       It is needed because when the absentee manager originally makes
   *  the reservation it does not know the process_id of the process
   *  it will create.  Because of this it is possible for a different
   *  job with the same group_id to claim the reservation.  This problem
   *  is avoided by having the absentee manager call res_pre_claim
   *  Which will fill in the process_id of the job for which the
   *  reservation was really made.
*/

/*
   Written by R.J.C. Kissel 5/78.
   Modfied by R.J.C. Kissel on 1/79 to do proper reservation accounting and log res id.
*/

/* Arguments */

dcl  a_reservation_id fixed bin (71);
dcl  a_group_id char (*);
dcl  a_process_id bit (36);
dcl  a_code fixed bin (35);

/* Local Variables */

dcl  res_id fixed bin (71);
dcl  log_res_id char (19);
dcl  grp_id char (32) aligned;
dcl  prc_id bit (36);
dcl  code fixed bin (35);
dcl  i fixed bin;					/* Index in rcpd. */
dcl  any_found bit (1);

dcl  caller_level fixed bin;

/* Local Constants */

/* Local Overlays */

/* Include Files */

%include rcp_data;
%include rcp_com_seg;
%include rcp_account_msg;
%include syserr_constants;

/* External Entries */

dcl  cu_$level_get entry (fixed bin);
dcl  cu_$level_set entry (fixed bin);
dcl  request_id_ entry (fixed bin (71)) returns (char (19));
dcl  get_ring_ entry returns (fixed bin);
dcl  rcp_pointers_$data entry returns (ptr);
dcl  rcp_pointers_$com_seg
     entry returns (ptr);
dcl  rcp_lock_$lock entry (ptr, fixed bin (35));
dcl  rcp_lock_$unlock entry (ptr);
dcl  rcp_match_user_name_
     entry (char (32) aligned, char (32) aligned) returns (bit (1));
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  admin_gate_$syserr entry options (variable);

/* External Constants */

dcl  error_table_$noentry
     fixed bin (35) external;
dcl  error_table_$badcall
     fixed bin (35) external;

/* Builtin Functions and Conditions */

dcl (addr, rel, unspec) builtin;
dcl (cleanup) condition;

	res_id = a_reservation_id;
	grp_id = a_group_id;
	prc_id = a_process_id;

	call cu_$level_get (caller_level);

	on cleanup
	     call cleanup_handler;

	call cu_$level_set (get_ring_ ());

	rcpd_ptr = rcp_pointers_$data ();
	rcs_ptr = rcp_pointers_$com_seg ();

	log_res_id = request_id_ (res_id);
						/* Set this for later use. */

	call rcp_lock_$lock (addr (rcpd.lock_info), code);

	if code ^= 0
	then goto BAD_ERROR;

/*
   *       Loop through the rcp data base looking for the reservation
   *  id.  Then change the entry by adding the process_id and
   *  leaving everything else the same.
*/
	any_found = "0"b;

	do i = 1 to rcpd.tot_devices;
	     if rcpd.device (i).reservation_id = res_id
	     then do;

		if ^rcp_match_user_name_ (rcpd.device (i).group_id, grp_id)
		then goto BAD_GROUP;

		any_found = "1"b;
		rcpd.device (i).process_id = prc_id;

		call ACCOUNT_WAKEUP (addr (rcpd.device (i)), RCP_ACCTMSG_assign);
						/* Take care of accting when done by the Initializer. */

		call admin_gate_$syserr (JUST_LOG, "RCP: Pre-claimed device ^a for ^a (prc_id=^o   res_id=^a)",
		     rcpd.device (i).device_name, grp_id, prc_id, log_res_id);
	     end;
	end;

	do i = 1 to rcpd.last_volume;
	     if rcpd.volume (i).reservation_id = res_id
	     then do;

		if ^rcp_match_user_name_ (rcpd.volume (i).group_id, grp_id)
		then goto BAD_GROUP;

		any_found = "1"b;
		rcpd.volume (i).process_id = prc_id;
		call admin_gate_$syserr (JUST_LOG, "RCP: Pre-claimed volume ^a for ^a (prc_id=^o   res_id=^a)",
		     rcpd.volume (i).volume_name, grp_id, prc_id, log_res_id);
	     end;
	end;

	if ^any_found
	then a_code = error_table_$noentry;
	else a_code = 0;

	call rcp_lock_$unlock (addr (rcpd.lock_info));
	call cu_$level_set (caller_level);
	return;

BAD_ERROR:
	call cleanup_handler;
	a_code = code;
	return;

BAD_GROUP:
	call cleanup_handler;
	a_code = error_table_$badcall;
	return;

ACCOUNT_WAKEUP:
	procedure (a_devptr, a_action);

/*	This procedure is called to format an accounting message, and send it to the
   *	accounting process.  If the accounting event channel has not been set up, no message is sent.
*/


dcl  a_devptr ptr;					/* Pointer to rcp_data entry */
dcl  a_action fixed bin;				/* Accounting action */

dcl  wakeup_buf fixed bin (71);
dcl 1 auto_rcpamsg like rcp_account_msg aligned;

	     unspec (auto_rcpamsg) = "0"b;

	     auto_rcpamsg.device_user_procid = a_devptr -> device.process_id;
	     auto_rcpamsg.rcp_data_relp = rel (a_devptr);
	     auto_rcpamsg.devtype = a_devptr -> device.dtypex;
	     auto_rcpamsg.action = a_action;

	     unspec (wakeup_buf) = unspec (auto_rcpamsg);
	     if rcpd.accounting_chan ^= 0
	     then call hcs_$wakeup (rcpd.accounting_pid, rcpd.accounting_chan, wakeup_buf, (0));

	end ACCOUNT_WAKEUP;

cleanup_handler:
	proc;

	     call rcp_lock_$unlock (addr (rcpd.lock_info));
	     call cu_$level_set (caller_level);

	end cleanup_handler;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message: 
   RCP: Pre-claimed device devX_MM for GRP_ID (prc_id= PRC_ID res_id= RES_ID)

   S:	$log

   T:	$run

   M:	An announcement that the absentee manager has preclaimed a device
	for its use.

   A:	$ignore

   Message: 
   RCP: Pre-claimed volume VOL_NAME for GRP_ID (prc_id= PRC_ID res_id= RES_ID)

   S:	$log

   T:	$run

   M:	An announcement that the absentee manager has preclaimed a volume
	for its use.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end rcp_pre_claim_;




		    rcp_preload_.pl1                11/11/89  1110.3r   11/11/89  0805.5      103491



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_preload_:
     proc (arg_device_name, arg_volume_name, arg_group_id, arg_ecode);


/*

   This program implements the preload operator command support
   in ring one.


   Created on 04/20/78 by Michael R. Jordan
   Modified on 08/17/78 by Michael R. Jordan
   Modified 6/79 by Michael R. Jordan to fix misc bugs.
   Modified 021585 by M. M. Pozzo to interface with rcp_access_kernel_ and
   general cleanup for B2 effort.

*/

dcl	addr		   builtin;
dcl	admin_gate_$syserr	   options (variable);
dcl	arg_device_name	   char (32);		/* name of the device */
dcl	arg_ecode		   fixed bin (35);		/* status code returned */
dcl	arg_group_id	   char (32);		/* name of the user */
dcl	arg_volume_name	   char (32);		/* name of the volume */
dcl	caller_level	   fixed bin;		/* callers validation level */
dcl	cleanup		   condition;
dcl	clock		   builtin;
dcl	cu_$level_get	   entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	device_name	   char (8);		/* local copy of device name */
dcl	device_off	   bit (18);		/* offset of rcpd.device entry */
dcl	dtypex		   fixed bin;		/* device type table index */
dcl	ecode		   fixed bin (35);		/* local status code */
dcl	effmode		   bit (3);
dcl	error_table_$device_busy
			   fixed bin (35) ext;
dcl	error_table_$incorrect_device_type
			   fixed bin (35) ext;
dcl	error_table_$incomplete_access_name
			   fixed bin (35) ext;
dcl	error_table_$noarg	   fixed bin (35) ext;
dcl	error_table_$resource_unknown
			   fixed bin (35) ext;
dcl	error_table_$volume_busy
			   fixed bin (35) ext;

dcl	access_operations_$rcp_preload
			   bit (36) aligned ext static;

dcl	get_authorization_	   entry () returns (bit (72) aligned);
dcl	get_ring_		   entry () returns (fixed bin);
dcl	group_id		   char (32);		/* local copy of user name */
dcl	i		   fixed bin;
dcl	null		   builtin;
dcl	operation		   bit (36) aligned;
dcl	ptr		   builtin;
dcl	rel		   builtin;
dcl	reg_iocb_ptr	   ptr;
dcl	1 res_info	   aligned automatic like resource_info;
dcl	1 req_info	   aligned automatic like requestor_info;
dcl	rcp_access_kernel_	   entry (bit (36) aligned, ptr, ptr, bit (3), fixed bin (35));
dcl	rcp_lock_$lock	   entry (ptr, fixed bin (35));
dcl	rcp_lock_$unlock	   entry (ptr);
dcl	rcp_match_user_name_   entry (char (32), char (32)) returns (bit (1));
dcl	rcp_pointers_$data	   entry () returns (ptr);
dcl	rcp_unload_$unload_device
			   entry (ptr, bit (1));
dcl	record_ptr	   ptr;
dcl	this_device_off	   bit (18);		/* device_off for the device being preloaded */
dcl	trans_iocb_ptr	   ptr;
dcl	volume_off	   bit (18);
dcl	volume_name	   char (32);		/* local copy of volume name */

/*                   CONSTANTS                          */

dcl	DEFAULT_REGISTRY_DIR   char (64) internal static options (constant) init (">sc1>rcp");
						/*

						   Get the callers validation level and get him set to go.

						*/


	call cu_$level_get (caller_level);
	on cleanup
	     begin;
	     call cu_$level_set (caller_level);
	end;
	call cu_$level_set (get_ring_ ());
	reg_iocb_ptr, trans_iocb_ptr = null ();
	ecode = 0;


/*

   Now copy all input arguments.

*/


	device_name = arg_device_name;
	volume_name = arg_volume_name;
	group_id = arg_group_id;

	rcpd_ptr = rcp_pointers_$data ();
	if ^rcpd.modes.resource_mgmt_enabled then
	     if group_id = "" then do;
		arg_ecode = error_table_$noarg;
		return;
	     end;
	if group_id ^= "" then
	     if incomplete_name (group_id) then do;
		arg_ecode = error_table_$incomplete_access_name;
		return;
	     end;

/* See if the volume is available */

	volume_off = "0"b;
	do i = 1 to rcpd.last_volume while (volume_off = "0"b);
	     volume_ptr = addr (rcpd.volume (i));
	     if volume.volume_name = volume_name then
		volume_off = rel (volume_ptr);
	end;
	if volume_off ^= "0"b then do;
	     if volume.state = 2 | volume.state = 3 then do;
		ecode = error_table_$volume_busy;
		goto UNLOCK_AND_RETURN;
	     end;
	     if volume.state = 1 | volume.state = 4 then do;
		if ((group_id ^= "") & (^rcp_match_user_name_ ((volume.group_id), group_id))) | (group_id = "")
		then do;
		     ecode = error_table_$volume_busy;
		     goto UNLOCK_AND_RETURN;
		end;
	     end;
	end;					/*

						   Make sure this device type is known before we go any farther.

						*/


	do dtypex = 1 to rcpd.tot_dtypes;

	     do device_off = rcpd.dtype (dtypex).first_off repeat device.next_off while (device_off ^= "0"b);
		device_ptr = ptr (rcpd_ptr, device_off);
		if device_name = device.device_name then
		     goto FOUND_DEVICE;
	     end;

	end;

	ecode = error_table_$resource_unknown;
	goto RETURN;


/*

   Got the device, now is the volume in use?

*/


FOUND_DEVICE:
	if dtypex ^= TAPE_DRIVE_DTYPEX & dtypex ^= DISK_DRIVE_DTYPEX then do;
						/* Not tape or disk. */
	     ecode = error_table_$incorrect_device_type;
	     goto RETURN;
	end;

	call rcp_lock_$lock (addr (rcpd.lock_info), ecode);
	if ecode ^= 0 then
	     goto RETURN;

	if device.flags.attached then do;		/* Someone has this one attached! */
	     ecode = error_table_$device_busy;
	     goto UNLOCK_AND_RETURN;
	end;

	goto STATE (device.state);			/* Cross-check the device state */


STATE (2):					/* DELETED - cannot allow this */
STATE (3):					/* STORAGE SYSTEM - this should never happen */
	ecode = error_table_$device_busy;
	goto UNLOCK_AND_RETURN;


STATE (1):					/* ASSIGNED - make sure this is the right user */
STATE (4):					/* RESERVED - ditto */
						/* If its not assigned or reserved to this user then it can't
						   be preloaded and if the group_id is "" then we can't tell
						   so deny preload */
	if ((group_id ^= "") & (^rcp_match_user_name_ ((device.group_id), group_id))) | (group_id = "") then do;
	     ecode = error_table_$device_busy;
	     goto UNLOCK_AND_RETURN;
	end;


STATE (0):					/* FREE - no sweat */
	this_device_off = device_off;

/*           If the volume is free or not in rcp_data yet, see if we
   have access to it - if we don't, then don't preload it
   since we can't get it.  If the device is free, check it's
   access as well for the same reason.   */

	if volume_off = "0"b | volume.state = 0 then do;
	     call setup_kernel_call ((VOLUME_TYPE (device.dtypex)), (volume_name), ecode);
	     if ecode ^= 0 then
		goto UNLOCK_AND_RETURN;
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), effmode, ecode);
	     if ecode ^= 0 then do;
		ecode = error_table_$volume_busy;
		goto UNLOCK_AND_RETURN;
	     end;
	     call cleanup_kernel_call (ecode);
	end;
	if device.state = 0 then do;
	     call setup_kernel_call ((DEVICE_TYPE (device.dtypex)), (device_name), ecode);
	     if ecode ^= 0 then
		goto UNLOCK_AND_RETURN;
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), effmode, ecode);
	     if ecode ^= 0 then do;
		ecode = error_table_$device_busy;
		goto UNLOCK_AND_RETURN;
	     end;
	     call cleanup_kernel_call (ecode);
	end;

/*

   We have all we need.  Make the note of this volume on this device.

*/


	device_ptr = ptr (rcpd_ptr, this_device_off);
	if device.volume_name ^= "" then
	     if device.volume_name ^= volume_name then
		call rcp_unload_$unload_device (device_ptr, "1"b);
	device.volume_name = volume_name;
	if device.state = 0 then do;			/* only set if device is free */
	     device.group_id = group_id;
	     device.state_time = clock ();
	end;

	call admin_gate_$syserr (0, "RCP: Preload volume ^a on device ^a^[ for ^a^;^s^].", volume_name, device_name,
	     (group_id ^= ""), group_id);


/*

   Now return to the caller in a proper manner.

*/


UNLOCK_AND_RETURN:
	call cleanup_kernel_call (ecode);
	call rcp_lock_$unlock (addr (rcpd.lock_info));


RETURN:
	arg_ecode = ecode;
	call cu_$level_set (caller_level);
	return;
%page;
setup_kernel_call:
     proc (a_resource_type, a_resource_name, a_code);

dcl	(a_resource_type, a_resource_name)
			   char (*) aligned;
dcl	a_code		   fixed bin (35);
dcl	local_code	   fixed bin (35);

dcl	rcprm_registry_util_$grab_transaction_control_file
			   entry (ptr, char (*) aligned, fixed bin (35));
dcl	rcprm_registry_util_$grab_registry
			   entry (ptr, char (*) aligned, char (*) aligned, fixed bin (35));
dcl	rcprm_registry_util_$find_resource_record
			   entry (ptr, char (*) aligned, ptr, fixed bin (35));

	local_code = 0;
	req_info.user_id = group_id;
	req_info.current_authorization = get_authorization_ ();
	req_info.validation_level = caller_level;
	operation = access_operations_$rcp_preload;
	if rcpd.modes.resource_mgmt_enabled then do;
	     res_info.registry_dir = DEFAULT_REGISTRY_DIR;
	     call rcprm_registry_util_$grab_transaction_control_file (trans_iocb_ptr, res_info.registry_dir, local_code)
		;
	     if local_code ^= 0 then
		goto SETUP_RETURN;
	     call rcprm_registry_util_$grab_registry (reg_iocb_ptr, res_info.registry_dir, a_resource_type, local_code);
	     if local_code ^= 0 then
		goto SETUP_RETURN;
	     call rcprm_registry_util_$find_resource_record (reg_iocb_ptr, a_resource_name, record_ptr, local_code);
	     if local_code ^= 0 then
		goto SETUP_RETURN;
	     res_info.registry_switch_ptr = reg_iocb_ptr;
	     res_info.registry_record_ptr = record_ptr;
	end;
	else do;
	     res_info.registry_dir = "";
	     res_info.registry_switch_ptr, res_info.registry_record_ptr = null ();
	end;
	res_info.resource_type = a_resource_type;
	res_info.resource_name = a_resource_name;

SETUP_RETURN:
	a_code = local_code;
     end setup_kernel_call;
%page;
cleanup_kernel_call:
     proc (a_code);

dcl	a_code		   fixed bin (35);
dcl	local_code	   fixed bin (35);
dcl	rcprm_registry_util_$release_transaction_control_file
			   entry (ptr, fixed bin (35));
dcl	rcprm_registry_util_$release_registry
			   entry (ptr, fixed bin (35));

	local_code = 0;
	if reg_iocb_ptr ^= null () then
	     call rcprm_registry_util_$release_registry (reg_iocb_ptr, local_code);
	if trans_iocb_ptr ^= null () then
	     call rcprm_registry_util_$release_transaction_control_file (trans_iocb_ptr, local_code);
	if local_code ^= 0 then
	     a_code = local_code;

     end cleanup_kernel_call;
%page;
incomplete_name:
     proc (a_group_id) returns (bit (1));

dcl	a_group_id	   char (*);
dcl	after		   builtin;

	if after ((after (a_group_id, ".")), ".") = "" then
	     return ("1"b);
	else return ("0"b);
     end incomplete_name;
%page;
%include rcp_resource_info;
%page;
%include rcp_requestor_info;
%page;
%include rcp_com_seg;
%page;
%include rcp_data;
%page;
%include rcp_resource_types;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Preload volume VOLUME on device DEVICE

   S:	$info

   T:	$run

   M:	The operator request to preload has been accepted by RCP.

   A:	Preload the volume in question on the specified device.


   END MESSAGE DOCUMENTATION */


     end rcp_preload_;




		    rcp_promote_.pl1                11/11/89  1110.3r   11/11/89  0807.0       36027



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


rcp_promote_:  procedure (arg_rcp_id, arg_new_level, arg_ecode);

/*	This program implements the rcp_$promote entry.
*	Created on 11/14/74 by Bill Silver.
*
*	This procedure is called to change (promote or demote) the caller's
*	validation level for the specified RCS entry.  This validation
*	level defines the highest ring from which calls can be made to RCP
*	(and also IOI) that involve this RCS entry.  If there is another
*	RCS entry associated with this one then it will also be promoted.
*	If an attachment kind of RCS entry is found then IOI will be called
*	to promote the associated device if the attachment has completed.
*/

dcl	arg_ecode		fixed bin(35);	/* (O) error_table_ code. */
dcl	arg_new_level	fixed bin;	/* (I) New validation level. */
dcl	arg_rcp_id	bit(36) aligned;	/* (I) RCP ID. */

dcl	caller_level	fixed bin;	/* Caller's validation level. */
dcl	ecode		fixed bin(35);	/* error_table_ code. */
dcl	new_level		fixed bin;	/* New validation level. */
dcl	rcp_id		bit(36)  aligned;	/* RCP ID. */
dcl	rcse_off		bit(18);		/* Offset of RCS entry. */

dcl	cleanup		condition;	/* Used to set up cleanup handler. */

dcl     (	ptr )  builtin;

dcl	admin_gate_$ioi_promote	entry  (fixed bin, fixed bin, fixed bin(35));
dcl	cu_$level_get		entry  (fixed bin);
dcl	cu_$level_set		entry  (fixed bin);
dcl	get_ring_			entry  returns(fixed bin);
dcl	rcp_validate_		entry  (bit(36) aligned, fixed bin, ptr, fixed bin(35));
/*	*/
%include rcp_com_seg;
/*	*/
	rcp_id = arg_rcp_id;		/* Copy arguments. */
	new_level = arg_new_level;

	call cu_$level_get (caller_level);	/* Save caller's validation level. */
	on   cleanup  begin;		/* If trouble reset level. */
	     call cu_$level_set (caller_level);
	end;
	call cu_$level_set (get_ring_());	/* Set validation level to RCP level. */

	call rcp_validate_ (rcp_id, caller_level, rcse_ptr, ecode);
	if   ecode ^= 0			/* Can't change level if call is invalid. */
	     then goto PROMOTE_RETURN;

	call PROMOTE;			/* Promote this RCS entry. */
	if   ecode ^= 0
	     then goto PROMOTE_RETURN;

	if   rcse.rcse_off ^= "0"b		/* Is there an associated entry? */
	     then do;			/* Yes, promote it too. */
		rcse_ptr = ptr(rcse_ptr, rcse.rcse_off);
		call PROMOTE;
	     end;

PROMOTE_RETURN:
	call cu_$level_set (caller_level);	/* Reset validation level. */
	arg_ecode = ecode;			/* Return whatever code we have. */
	return;
/*	*/
PROMOTE:  procedure;

/*	This procedure is called to actually promote an RCS entry.
*	This involves just setting the caller_level in the entry.
*	However, if this is a completed attachment entry (thus already
*	promoted in IOI) then we must call IOI to promote this device
*	to the new level.  An incomplete attachment will not yet be promoted
*	by IOI in ring 0.  We must leave the ring 0 validation level at the
*	RCP level so the higher ring will not interfere with any RCP I/O.
*/
	rcse.caller_level = new_level;	/* Promote RCS entry. */

	if   rcse.kind ^= 1			/* Is it an attachment kind of entry? */
	     then return;			/* No. */

	if   rcse.state ^= 5		/* Is device attachment completed? */
	     then return;			/* No, not yet promoted by IOI in ring 0. */

					/* OK to promote in ring 0 since promoted once already. */
	call admin_gate_$ioi_promote (rcse.ioi_index, new_level, ecode);

	end  PROMOTE;

	end  rcp_promote_;




		    rcp_rcse_.pl1                   11/11/89  1110.3r   11/11/89  0807.0       88389



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


rcp_rcse_:  procedure;

/*	This program is an internal interface of RCP.
*	Created on 11/20/74 by Bill Silver.
*
*	This program manages the entries in RCS.  It also keeps a list of
*	the RCS entries used by this process.  There is a separate list for
*	attachments and assignments.  This program has the following entries:
*	     1.  get   -	Gets a free entry and assigns it to the calling process.
*	     2.  free  -	Frees an entry and puts it back onto the free list.
*	     3.  info  -	Returns the offset of the first entry and the total
*			number of entries in the attach and assign lists.
*/


/*		ARGUMENT  DATA		*/

dcl	arg_assign_off	bit(18);		/* (O) Offset of first entry in assign list. */
dcl	arg_attach_off	bit(18);		/* (O) Offset of first entry in attach list. */
dcl	arg_ecode		fixed bin(35);	/* (O) error_table_ code. */
dcl	arg_num_assign	fixed bin;	/* (O) Number of assignment RCS entries. */
dcl	arg_num_attach	fixed bin;	/* (O) Number of attachment RCS entries. */
dcl	arg_rcse_ptr	ptr;		/* (I/O) Pointer to the RCSE we are dealing with. */


/*		AUTOMATIC  DATA		*/

dcl	ecode		fixed bin(35);	/* error_table_ code. */
dcl	frcse_off		bit(18);		/* Offset of RCS entry being freed. */
dcl	id_count		fixed bin;	/* Unique ID count. */
dcl	rcse_off		bit(18);		/* Offset of specified RCS entry. */
dcl	kind		fixed bin;	/* RCS entry kind. */
dcl	trcse_ptr		ptr;		/* Pointer to template RCSE. */
dcl	urcse_off		bit(18);		/* Offset of next entry on process list. */


/*		BASED  DATA		*/

dcl   1	trcse  like rcse  based(trcse_ptr)  aligned;  /* Used to copy template RCSE. */


/*		INTERNAL STATIC DATA	** Used to keep per process RCP info. */

dcl	attach_off	bit(18)		/* Top of attach RCS entry list for this process. */
	internal static	init ("0"b);
dcl	num_attach	fixed bin		/* Number of attach RCS entries for process. */
	internal static	init(0);
dcl	max_attach	fixed bin		/* Maximum number of attach entries allowed. */
	internal static	init (16);

dcl	assign_off	bit(18)		/* Top of assign list. */
	internal static	init ("0"b);
dcl	num_assign	fixed bin		/* Number of assign entries. */
	internal static	init (0);
dcl	max_assign	fixed bin		/* Max number of assign entries. */
	internal static	init (16);


/*		EXTERNAL ENTRIES CALLED	*/

dcl	cleanup		condition;	/* Cleanup handler needed to reset lock. */

dcl     (	addr, null, ptr, rel, string )  builtin;

dcl     (	error_table_$bad_index,
	error_table_$fatal_error,
	error_table_$noalloc )  fixed bin(35)  external;

dcl	clock_		entry  returns (fixed bin(71));
dcl	rcp_lock_$lock	entry  (ptr, fixed bin(35));
dcl	rcp_lock_$unlock	entry  (ptr);
dcl	rcp_pointers_$com_seg  entry  returns (ptr);
/*	*/
%include rcp_com_seg;
/*	*/
get:  entry  (arg_rcse_ptr, arg_ecode);

/*	This entry will get a free RCS entry and assign it to the calling process.
*	It will initialize the fields in this entry that are common to all kinds
*	of requests.  It will add this entry to the correct list of RCS entries
*	maintained for this process.
*/
	trcse_ptr = arg_rcse_ptr;		/* Get pointer to template RCSE. */
	rcs_ptr = rcp_pointers_$com_seg ();	/* Get pointer to base of RCS. */
	rcse_ptr = null();			/* No entry assigned yet. */
	lock_info_ptr = addr(rcs.lock_info);	/* Get pointer to lock structure. */
	kind = trcse.kind;			/* Get kind of RCSE to be allocated. */

	if   kind = 1			/* Has process RCS entry limit been reached? */
	     then if   num_attach = max_attach
		     then do;		/* Yes, too many attach RCS entries. */
			arg_ecode = error_table_$noalloc;
			return;
		     end;
		     else;
	     else if   num_assign = max_assign
		     then do;		/* Yes, too many assign RCS entries. */
			arg_ecode = error_table_$noalloc;
			return;
		     end;

	on   cleanup begin;			/* Must unlock RCS if trouble. */
	     call rcp_lock_$unlock (lock_info_ptr);
	end;

	call rcp_lock_$lock (lock_info_ptr, ecode);
	if   ecode ^= 0			/* Can't get entry if error in locking. */
	     then goto GET_RETURN;

	call GET_FREE_ENTRY;		/* Get pointer and offset of next free entry. */
	if   ecode ^= 0			/* Did we get one? */
	     then do;			/* No, unlock RCS. */
		call rcp_lock_$unlock (lock_info_ptr);
		goto GET_RETURN;
	     end;

	rcse = trcse;			/* Copy template RCSE into its real entry slot. */
	rcse.free_off = "0"b;		/* Not on free list now. */
	rcse.state = 1;			/* 1 => entry no longer free. */

	id_count,				/* Get next unique ID index. */
	rcs.id_count = rcs.id_count + 1;

	call rcp_lock_$unlock (lock_info_ptr);
	revert cleanup;

	rcse.state_time = clock_();		/* Now fill in other RCS entry fields. */
	addr(rcse.rcp_id)->based_rcp_id.id_count = id_count;
	addr(rcse.rcp_id)->based_rcp_id.rcse_off = rcse_off;

/*	Put this RCS entry at the top of the correct process entry list.
*/
	if   kind = 1			/* Which list should we add it to? */
	     then do;			/* Attachment list. */
		rcse.user_off = attach_off;	/* Link to previous first entry. */
		attach_off = rcse_off;	/* Set up new first entry. */
		num_attach = num_attach + 1;	/* Update count of attach RCS entries. */
	     end;
	     else do;			/* Assignment list. */
		rcse.user_off = assign_off;	/* Link up the same way. */
		assign_off = rcse_off;
		num_assign = num_assign + 1;
	     end;

GET_RETURN:
	arg_rcse_ptr = rcse_ptr;		/* Return arguments. */
	arg_ecode = ecode;
	return;
/*	*/
free:  entry  (arg_rcse_ptr, arg_ecode);

/*	This entry will put the specified RCS entry back onto the free list.
*	It will remove it from the correct RCP entries list maintained for
*	the process.
*/
	rcse_ptr = arg_rcse_ptr;		/* Argument points to specified entry. */
	kind = rcse.kind;			/* Get entry kind. */

	rcs_ptr = ptr(rcse_ptr, "0"b);	/* Get pointer to base of RCS. */
	lock_info_ptr = addr(rcs.lock_info);
	frcse_off = rel(rcse_ptr);		/* Get offset of RCS entry to be freed. */
	urcse_off = rcse.user_off;		/* Offset of next RCS entry on process list. */

	on   cleanup begin;			/* Must unlock RCS if trouble. */
	     call rcp_lock_$unlock (lock_info_ptr);
	end;

	call rcp_lock_$lock (lock_info_ptr, ecode);
	if   ecode ^= 0			/* Can't free if there is an error in locking. */
	     then goto FREE_RETURN;

/*	Reset entry values and put it back on free list.
*/
	rcse.state = 0;			/* Entry free. */
	rcse.kind = 0;			/* Free => no kind of RCS entry. */
	rcse.free_off = rcs.first_free_off;	/* Get offset of next free entry. */
	rcs.first_free_off = frcse_off;	/* Put on top of free list. */
	rcse.process_id = "0"b;		/* Process no longer owns this entry. */

	call rcp_lock_$unlock (lock_info_ptr);
	revert cleanup;

/*	Take this entry out of the process list that it is in.
*/
	if   kind = 1			/* Which list is it in? */
	     then do;			/* Attach list. */
		rcse_off = attach_off;	/* Get first attach RCS entry. */
		num_attach = num_attach - 1;	/* Update count of attach RCS entries. */
	     end;
	     else do;			/* Assign list. */
		rcse_off = assign_off;
		num_assign = num_assign - 1;
	     end;

	if   rcse_off = frcse_off		/* Are we freeing first entry on list? */
	     then do;			/* Yes, get new first entry. */
		if   kind = 1		/* Again, decide which list. */
		     then attach_off = urcse_off;
		     else assign_off = urcse_off;
		goto FREE_RETURN;
	     end;

	do   while (rcse_off ^= "0"b);	/* Not first entry.  Look through list. */
	     rcse_ptr = ptr(rcs_ptr, rcse_off);	/* Get pointer to current entry. */
	     if   rcse.user_off = frcse_off	/* Is next entry the one? */
		then do;			/* Yes, update value in next user offset. */
		     rcse.user_off = urcse_off;
		     goto FREE_RETURN;
		end;
	     rcse_off = rcse.user_off;	/* No, get next entry in this list. */
	end;

	ecode = error_table_$bad_index;	/* Bad trouble, entry not on list. */

FREE_RETURN:
	arg_ecode = ecode;
	return;
/*	*/
info:  entry  (arg_attach_off, arg_num_attach, arg_assign_off, arg_num_assign);

/*	This entry is called to get the offsets of the first RCS entry
*	on each of the process lists.  It will also return the number
*	of each kind of RCS entries.
*/
	arg_attach_off = attach_off;		/* Just get them from internal static. */
	arg_num_attach = num_attach;

	arg_assign_off = assign_off;
	arg_num_assign = num_assign;

	return;





GET_FREE_ENTRY:  procedure;

/*	This procedure is called to get the pointer and offset of a free RCS entry.
*	We will always get the first free entry.  If there are no free entries we
*	will add a new entry to RCS.
*/
	rcse_off = rcs.first_free_off;	/* Get offset of first free entry. */
	if   rcse_off ^= "0"b		/* Is there a free entry? */
	     then do;			/* Yes. */
		rcse_ptr = ptr(rcs_ptr,rcse_off);   /* Get pointer to this free entry. */
		rcs.first_free_off = rcse.free_off; /* Get next first free entry. */
		return;
	     end;

	if   rcs.num_entries = rcs.max_entries	/* No, is there room for another entry? */
	     then do;			/* No, we cannot get a free entry. */
		ecode = error_table_$fatal_error;
		return;
	     end;

	rcs.num_entries = rcs.num_entries + 1;	/* Room for another entry. */
	rcse_ptr = addr(rcs.entry(rcs.num_entries));
	rcse_off = rel(rcse_ptr);		/* Get pointer and offset of new entry. */

	end  GET_FREE_ENTRY;

	end  rcp_rcse_;




		    rcp_reconfigure_.pl1            11/11/89  1110.3rew 11/11/89  0805.9       36801



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


rcp_reconfigure_: procedure;

/*	This program implements the rcp_sys_$delete_device & rcp_sys_$add_device entries.
   *	Created on 12/09/74 by Bill Silver.
   *	Changed on 04/20/76 by Bill Silver for storage system disks.
   *	Modified 6/79 by Michael R. Jordan for MR7.0R.
   *      Modified 841009 to interface to rcp_control_ instead of
   *        rcp_initializer_... - M. M. Pozzo
   *	Modified 841121 to remove initializer variable bug introduced 
   *	during auditing (operation set to "" at COMMON)... -M. M. Pozzo
   *
   *	This program contains the following entry points:
   *	     1.	delete_device    -	Delete a device from the system.
   *	     2.	add_device       -	Add a deleted device back to the system.
*/

/*		ARGUMENT  DATA		*/

	dcl     arg_device_name	 char (*);	/* (I) Device name. */
	dcl     arg_ecode		 fixed bin (35);	/* (O) error_table_ code. */


/*		AUTOMATIC  DATA		*/

	dcl     device_offset	 bit (18) aligned;	/* needed by rcp_control_ */
	dcl     process_id		 bit (36) aligned;	/* needed by rcp_control */
	dcl     ssys_flag		 bit (1) aligned;	/* ON => storage system disk. */
	dcl     volume_offset	 bit (18) aligned;	/* needed by rcp_control_ */

	dcl     device_name		 char (32);	/* Device name. */
	dcl     operation		 bit (36) aligned;	/* Operation requested of rcp_control_ */

	dcl     caller_level	 fixed bin;	/* Caller's validation level. */
	dcl     ecode		 fixed bin (35);
	dcl     error_count		 fixed bin (17);	/* Errors on device attachment */

/*		EXTERNAL ENTRIES CALLED	*/

	dcl     cleanup		 condition;	/* Used to set up cleanup handler. */

	dcl     (addr, substr)	 builtin;

	dcl     cu_$level_get	 entry (fixed bin);
	dcl     cu_$level_set	 entry (fixed bin);
	dcl     get_ring_		 entry returns (fixed bin);
	dcl     mdx$add_del		 entry (char (*), bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     rcp_control_	 entry (bit (36) aligned, bit (18) aligned, bit (18) aligned, char (*),
				 fixed bin (17), bit (36) aligned, fixed bin (35));

	dcl     access_operations_$rcp_add_device ext static bit (36) aligned;
	dcl     access_operations_$rcp_delete_device ext static bit (36) aligned;

/*	These two entriy points are called to delete or add a device.
   *	A deleted device cannot be assigned to any process.
*/


delete_device: entry (arg_device_name, arg_ecode);

	operation = access_operations_$rcp_delete_device;	/* Delete this device. */
	goto COMMON;


add_device: entry (arg_device_name, arg_ecode);

	operation = access_operations_$rcp_add_device;	/* Add this device. */


COMMON:

	device_offset = ""b;
	process_id = ""b;
	volume_offset = ""b;
	device_name = "";
	error_count = 0;

	ecode = 0;
	call cu_$level_get (caller_level);
	on cleanup begin;
		call cu_$level_set (caller_level);
	     end;
	call cu_$level_set (get_ring_ ());

	device_name = arg_device_name;		/* Get argument. */

	if substr (device_name, 1, 3) = "dsk"		/* Is this a DISK type device? */
	then do;					/* Yes, see if it belongs to the storage system. */
		call mdx$add_del (device_name, (operation = access_operations_$rcp_add_device), ssys_flag, ecode);
		if ssys_flag then goto RETURN;	/* Is storage system then all done. */
	     end;

	call rcp_control_ (operation, volume_offset, device_offset,
	     device_name, error_count, process_id, ecode);


RETURN:
	call cu_$level_set (caller_level);
	arg_ecode = ecode;
	return;

     end rcp_reconfigure_;




		    rcp_reserve_.pl1                11/11/89  1110.3rew 11/11/89  0805.5      291051



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

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_reserve_:
     proc (a_resource_desc_ptr, a_resource_res_ptr, a_code);

/*
   *       This subroutine implements reservation in RCP.  It takes a
   *  reservation description and a resource description and manipulates
   *  rcp_data to make the reservations.
   *       This is a radical departure from RCP protocol which in the
   *  past required calling rcp_initializer_ to change rcp_data_.
*/

/*
   Written by R.J.C. Kissel 5/78.
   Modified by R.J.C. Kissel 1/79 to add unprivileged user reservations.
   Modified by R.J.C. Kissel 3/79 to allow multiple density requests.
   Modified 6/79 by Michael R. Jordan for MR7.0R.
   Modified 6/81 by C. D. Tavares to make scratch tapes re-usable.
   Modified 12/84 by Chris Jones for B2 security cleanup.
*/


/****^  HISTORY COMMENTS:
  1) change(85-07-12,Pozzo), approve(86-02-21,MCR7346), audit(86-07-29,Farley),
     install(86-08-01,MR12.0-1108):
     Modified to add auditing for denial of reservations of devices requested
     by name.
  2) change(85-07-24,ABall), approve(86-02-21,MCR7346), audit(86-07-29,Farley),
     install(86-08-01,MR12.0-1108):
     Fix bug involving validation level not being the caller's before calling
     rcprm_find_resource_$(reserve reserve_proxy).
  3) change(87-06-25,Rauschelbach), approve(87-06-29,MCR7736),
     audit(87-07-21,Farley), install(87-08-06,MR12.1-1063):
     System error message documentation was added.
                                                   END HISTORY COMMENTS */


/* Arguments */

dcl	a_resource_desc_ptr	   ptr;			/* The resource description structure. */
dcl	a_resource_res_ptr	   ptr;			/* The reservation description structure. */
dcl	a_code		   fixed bin (35);		/* A standard system status code. */

/* Local Variables */

/* See the resource_control_desc include file for local declarations of the input argument pointers. */

dcl	any_reserved	   bit (1) aligned;		/* Have any reservations been made. (for cleanup). */
dcl	attributes	   char (256) varying;	/* Storage for the attributes character string. */
dcl	authorization	   bit (72) aligned;	/* Authorization to be used for the reservation. */
dcl	caller_level	   fixed bin;		/* Caller's validation level. */
dcl	callers_resource_desc_ptr
			   ptr;			/* copy of caller supplied pointer */
dcl	callers_resource_res_ptr
			   ptr;			/* copy of caller supplied pointer */
dcl	code		   fixed bin (35);
dcl	density		   bit (5) aligned;		/* Density value for a tape drive. */
dcl	dtype_idx		   fixed bin;		/* Index into the dtype structure in rcpd. */
dcl	i		   fixed bin;		/* Current resource index. */
dcl	is_volume		   bit (1);		/* ON => resource type is a volume type */
dcl	log_res_id	   char (19);
dcl	model		   fixed bin (35);		/* Model number of a resource. */
dcl	num_free		   fixed bin;
dcl	operation		   bit (36) aligned;	/* RCP operation */
dcl	primary_type	   char (32);
dcl	process_id	   bit (36) aligned;
dcl	1 req_info	   aligned like requestor_info;
dcl	res_by		   char (32);
dcl	res_for		   char (32);		/* for cleanup handling. */
dcl	res_id		   fixed bin (71);		/* Copies of critical information needed */
dcl	1 res_info	   aligned like resource_info;
dcl	registry_directory	   char (64);		/* local var */
dcl	ret_ptr		   ptr;
dcl	rsc_name		   char (32);
dcl	rsc_type		   char (32);
dcl	saved_code	   fixed bin (35);		/* so we can remember we saw at least one error */
dcl	special_rdesc_ptr	   ptr;
dcl	special_resv_ptr	   ptr;
dcl	speed		   bit (3) aligned;		/* Allowable speeds */
dcl	system		   bit (1) aligned;		/* True if called through rcp_sys_ gate. */
dcl	tot_disk_drives	   fixed bin;		/* Number of tdisk drives requested. */
dcl	tot_tape_drives	   fixed bin;		/* Number of tape drives requested. */
dcl	tracks		   fixed bin (35);		/* Number of tracks for a tape drive. */

dcl	system_free_area	   area based (get_system_free_area_ ());

/* External Entries */

dcl	access_audit_r1_$log_general
			   entry options (variable);
dcl	admin_gate_$syserr	   entry options (variable);
dcl	cu_$level_get	   entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	cv_rcp_attributes_$to_string_rel
			   entry (char (*), bit (72) dim (4), char (*) varying, fixed bin (35));
dcl	get_authorization_	   entry () returns (bit (72) aligned);
dcl	get_ring_		   entry returns (fixed bin);
dcl	get_process_id_	   entry () returns (bit (36));
dcl	get_system_free_area_  entry () returns (ptr);
dcl	hcs_$wakeup	   entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl	mode_string_$parse	   entry (char (*), ptr, ptr, fixed bin (35));
dcl	rcp_access_kernel_	   entry (bit (36) aligned, ptr, ptr, bit (3), fixed bin (35));
dcl	rcp_pointers_$data	   entry returns (ptr);
dcl	rcp_pointers_$com_seg  entry returns (ptr);
dcl	rcp_lock_$lock	   entry (ptr, fixed bin (35));
dcl	rcp_lock_$unlock	   entry (ptr);
dcl	rcprm_find_resource_$reserve
			   entry (ptr, char (*), ptr, fixed bin (35));
dcl	rcprm_find_resource_$reserve_proxy
			   entry (ptr, char (*), ptr, char (*), bit (72) aligned, fixed bin (35));
dcl	request_id_	   entry (fixed bin (71)) returns (char (19));
dcl	resource_info_$get_type
			   entry (char (*), bit (1), fixed bin (35));
dcl	resource_info_$get_primary_type
			   entry (char (*), char (*), fixed bin (35));

/* External Constants */

dcl	error_table_$bad_conversion
			   fixed bin (35) external;
dcl	error_table_$badcall   fixed bin (35) external;
dcl	error_table_$resource_unknown
			   fixed bin (35) external;
dcl	error_table_$reservation_failed
			   fixed bin (35) external;
dcl	error_table_$unimplemented_version
			   fixed bin (35) external;
dcl	error_table_$device_limit_exceeded
			   fixed bin (35) external;

dcl	access_operations_$rcp_reserve
			   bit (36) aligned ext static;

/* Builtin Functions and Conditions */

dcl	(addr, clock, hbound, lbound, null, ptr, rel, rtrim, size, unspec)
			   builtin;
dcl	(cleanup)		   condition;

	authorization = get_authorization_ ();
	system = "0"b;
	goto START;

sys:
     entry (a_resource_desc_ptr, a_resource_res_ptr, a_authorization, a_code);

dcl	a_authorization	   bit (72) aligned;

	authorization = a_authorization;
	system = "1"b;
	goto START;

START:
	operation = access_operations_$rcp_reserve;

	any_reserved = "0"b;
	rcpd_ptr = null ();
	rcs_ptr = null ();
	registry_directory = ">sc1>rcp";
	resource_desc_ptr = null ();
	resource_res_ptr = null ();
	mode_string_info_ptr = null ();
	special_rdesc_ptr = null ();
	special_resv_ptr = null ();

	call cu_$level_get (caller_level);

	on cleanup call cleanup_handler;

	call cu_$level_set (get_ring_ ());

	call copy_resource_and_reservation_structures;

	rcpd_ptr = rcp_pointers_$data ();
	rcs_ptr = rcp_pointers_$com_seg ();

	res_for = reservation_description.reserved_for;
	res_by = reservation_description.reserved_by;
	res_id = clock ();
	log_res_id = request_id_ (res_id);
	process_id = get_process_id_ ();

/*
   *       The following code will do some consistency checks and
   *  limit checks on the input structures before actually trying
   *  to make the reservations.
*/

	if ^system & (res_for ^= res_by) then
	     goto BAD_NAME;

	if resource_descriptions.version_no ^= resource_desc_version_1
	     | reservation_description.version_no ^= resource_res_version_1 then
	     goto BAD_VERSION;

	if resource_descriptions.n_items ^= reservation_description.n_items | resource_descriptions.n_items = 0 then
	     goto BAD_CALL;

	tot_tape_drives = 0;
	tot_disk_drives = 0;

	saved_code = 0;
	do i = 1 to Resource_count;			/* Check device limits. */

	     call resource_info_$get_primary_type ((resource_descriptions.item (i).type), primary_type, code);

	     if code ^= 0 then do;
		rsc_type = resource_descriptions.item (i).type;
		saved_code, callers_resource_desc_ptr -> resource_descriptions.item (i).status_code = code;
	     end;
	     else callers_resource_desc_ptr -> resource_descriptions.item (i).type = primary_type;

	     if primary_type = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then
		tot_tape_drives = tot_tape_drives + 1;

	     else if primary_type = DEVICE_TYPE (DISK_DRIVE_DTYPEX) then
		tot_disk_drives = tot_disk_drives + 1;

	end;					/* Check device limits. */

	if saved_code ^= 0 then
	     goto BAD_RESOURCE;

	if ^system then do;				/* Check all device usage for this process. */
	     do device_ptr = ptr (rcpd_ptr, rcpd.dtype (TAPE_DRIVE_DTYPEX).first_off)
		repeat ptr (device_ptr, device.next_off) while (rel (device_ptr) ^= ""b);

		if device.state ^= FREE & device.process_id = process_id then
		     tot_tape_drives = tot_tape_drives + 1;

	     end;

	     do device_ptr = ptr (rcpd_ptr, rcpd.dtype (DISK_DRIVE_DTYPEX).first_off)
		repeat ptr (device_ptr, device.next_off) while (rel (device_ptr) ^= ""b);
		if device.state ^= FREE & device.process_id = process_id then
		     tot_disk_drives = tot_disk_drives + 1;

	     end;
	end;					/* Check all device usage for this process. */

	if rcpd.dtype (TAPE_DRIVE_DTYPEX).max_concurrent < tot_tape_drives
	     | rcpd.dtype (DISK_DRIVE_DTYPEX).max_concurrent < tot_disk_drives then
	     goto TOO_MANY_DEVICES;

/*
   *       Process each resource in turn, doing all the work ourselves.
   *  Rcp_initializer_ is not called to manipulate rcp_data.  This is a
   *  break with the past protocol for RCP.
   *       The cleanup handler will cancel any reservations already
   *  made if any one fails.  This makes the reservation of a group
   *  of resources appear as an indivisible operation to the caller
   *  of this subroutine.
*/

	call rcp_lock_$lock (addr (rcpd.lock_info), code);

	if code ^= 0 then
	     goto BAD_ERROR;

	allocate resource_descriptions in (system_free_area) set (special_rdesc_ptr);
	allocate reservation_description in (system_free_area) set (special_resv_ptr);
	call copy_rdesc_and_resv ();
	do i = 1 to resource_descriptions.n_items;

	     special_rdesc_ptr -> resource_descriptions.item (1) = resource_descriptions.item (i);
	     special_resv_ptr -> reservation_description.reservation_group (1) =
		reservation_description.reservation_group (i);
	     rsc_type = resource_descriptions.item (i).type;
	     rsc_name = resource_descriptions.item (i).name;

	     if rsc_type = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then
		dtype_idx = TAPE_DRIVE_DTYPEX;

	     else if rsc_type = DEVICE_TYPE (DISK_DRIVE_DTYPEX) then
		dtype_idx = DISK_DRIVE_DTYPEX;

	     else if rsc_type = VOLUME_TYPE (TAPE_VOL_VTYPEX) | rsc_type = VOLUME_TYPE (DISK_VOL_VTYPEX) then
		dtype_idx = 0;

	     else goto BAD_RESOURCE;

	     if dtype_idx ^= 0 then do;		/* Reserve a device. */
		dtype_ptr = addr (rcpd.dtype (dtype_idx));

		call select_device (ret_ptr);

		if ret_ptr = null then
		     goto RESERVATION_FAILED;

		device_ptr = ret_ptr;

/*
   The device.group_id will be set later after we know that the reservation
   is possible.  This will avoid destroying information needed for
   pre-loaded volumes if the reservation fails.
*/

		device.reservation_id = res_id;
		device.reserved_by = res_by;

		if system then
		     device.process_id = "0"b;
		else device.process_id = process_id;

		device.current_authorization = authorization;

		device.state_time = clock ();
		device.state = RESERVED;

		any_reserved = "1"b;

		if ^system			/* For system, call is in rcp_pre_claim_ */
		     then
		     call ACCOUNT_WAKEUP (device_ptr, RCP_ACCTMSG_assign);

		call admin_gate_$syserr (JUST_LOG, "RCP: Reserved device ^a for ^a (id=^a)", device.device_name,
		     res_for, log_res_id);
	     end;					/* Reserve a device. */

	     else do;				/* Reserve a volume. */

		call select_volume (ret_ptr);

		if ret_ptr = null then
		     goto RESERVATION_FAILED;

		volume_ptr = ret_ptr;

		volume.volume_name = rsc_name;
		volume.group_id = res_for;

		do volume.vtypex = lbound (VOLUME_TYPE, 1) to hbound (VOLUME_TYPE, 1)
		     while (rsc_type ^= VOLUME_TYPE (volume.vtypex));
		end;				/* Look up the volume type index. */

		if volume.volume_name = "scratch" then
		     volume.volume_name = "";

		volume.reservation_id = res_id;
		volume.reserved_by = res_by;

		if system then
		     volume.process_id = "0"b;
		else volume.process_id = process_id;

		volume.current_authorization = authorization;

		volume.state_time = clock ();
		volume.state = RESERVED;

		any_reserved = "1"b;

		call admin_gate_$syserr (JUST_LOG, "RCP: Reserved volume ^a for ^a (id=^a)", volume.volume_name,
		     volume.group_id, log_res_id);
	     end;					/* Reserve a volume. */

	     call copy_back_rdesc_and_resv (i);
	end;					/* do loop */

/* If these reservations would leave too few tape drives for system processes,
   the reservation must fail. */

	num_free = 0;

	do device_ptr = ptr (rcpd_ptr, rcpd.dtype (TAPE_DRIVE_DTYPEX).first_off)
	     repeat ptr (device_ptr, device.next_off) while (rel (device_ptr) ^= ""b);
	     if device.state = FREE then
		num_free = num_free + 1;
	end;

	if num_free < rcpd.dtype (TAPE_DRIVE_DTYPEX).num_reserved then
	     goto RESERVATION_FAILED;

	do i = 1 to rcpd.tot_devices;			/* Set group id's for a successful reservation. */
	     if rcpd.device (i).reservation_id = res_id then
						/* Set the group id and interact with preloaded volumes. */
		rcpd.device (i).group_id = res_for;
	end;

	call rcp_lock_$unlock (addr (rcpd.lock_info));
	call free_storage;
	callers_resource_res_ptr -> reservation_description.reservation_id = res_id;
	a_code = 0;				/* Everything went all right. */
	call cu_$level_set (caller_level);
	return;

approve_schedule:
     entry (a_resource_desc_ptr, resource_no, registry_dir, reserver_info_ptr, reserver_chain, a_code);

/* This entry is called by rcprm_find_resource_$reserve when it wants to ask if its choice of
   an appropriate and accessible resource happens to be available at the required time. */
/* Currently, only tape or disk volumes will be checked, devices are handled at other places in RCP. */

dcl	(
	resource_no	   fixed bin,
	registry_dir	   char (*),
	reserver_info_ptr	   pointer,
	reserver_chain	   bit (18) unaligned
	)		   parameter;

dcl	error_table_$resource_reserved
			   fixed bin (35) external;

	resource_desc_ptr = a_resource_desc_ptr;	/* special copying not necessary since caller has done it */
	rsc_name = resource_descriptions.item (resource_no).name;
	call resource_info_$get_type ((resource_descriptions.item (resource_no).type), is_volume, code);
	if code ^= 0 then do;
	     a_code, resource_descriptions.item (resource_no).status_code = code;
	     return;
	end;

	if is_volume then do;			/* Check rcpdata for these. */
	     rcpd_ptr = rcp_pointers_$data ();

	     do i = 1 to rcpd.last_volume while (rcpd.volume (i).volume_name ^= rsc_name);
	     end;

	     if i > rcpd.last_volume then
		a_code = 0;
	     else if rcpd.volume (i).state = FREE then
		a_code = 0;
	     else a_code = error_table_$resource_reserved;
	end;					/* Check rcp data for these. */

	else a_code = 0;

	return;

BAD_CALL:
	call cleanup_handler;
	a_code = error_table_$badcall;
	return;

BAD_VERSION:
	call cleanup_handler;
	a_code = error_table_$unimplemented_version;
	return;

TOO_MANY_DEVICES:
	call cleanup_handler;
	a_code = error_table_$device_limit_exceeded;
	return;

BAD_RESOURCE:
	call cleanup_handler;
	a_code = error_table_$resource_unknown;
	return;

BAD_ERROR:
	call admin_gate_$syserr (JUST_LOG,
	     "RCP: An error locking rcpd for reservation for ^a ^[^s^;^xby^x^a^] (id=^a).", res_for, res_for = res_by,
	     res_by, log_res_id);
	call cleanup_handler;
	a_code = code;
	return;

RESERVATION_FAILED:
	call cleanup_handler;
	a_code = error_table_$reservation_failed;
	return;

BAD_NAME:
	call cleanup_handler;
	a_code = error_table_$reservation_failed;
	return;

BAD_ATTRIBUTE:
	call cleanup_handler;
	a_code = error_table_$bad_conversion;
	return;

select_device:
     proc (dptr);

/* Arguments */

dcl	dptr		   ptr;			/* Pointer to device entry we eventurally select. */

/* Local Variables */

dcl	MAX_AVAILABLE	   fixed bin (17) static internal options (constant) init (128);
dcl	1 AA_array	   (MAX_AVAILABLE),
	  2 name		   char (8),
	  2 last_time	   fixed bin (71),
	  2 dptr		   ptr;
dcl	loop		   fixed bin;
dcl	current_AA	   fixed bin;
dcl	start		   fixed bin;
dcl	found		   bit (1);

	call get_attr_values ();

	dptr = null;
	current_AA = 0;

	do device_ptr = ptr (rcpd_ptr, dtype.first_off) repeat ptr (device_ptr, device.next_off)
	     while (rel (device_ptr) ^= ""b & (current_AA <= MAX_AVAILABLE));

	     if device.state = FREE then		/* It's available. */
		if (model = 0 | device.model = model) then
		     if (tracks = 0 | device.qualifiers (1) = tracks) then
			if (density = "0"b | (unspec (device.qualifiers (2)) & density) = density) then
			     if (speed = ""b | (unspec (device.qualifiers (3)) & speed) ^= "0"b) then
				if (rsc_name = "" | device.device_name = rsc_name) then do;
				     start = 1;
				     found = "0"b;
				     do start = 1 to current_AA while (^found);
					if device.state_time < AA_array.last_time (start) then
					     found = "1"b;
				     end;
				     if found & (start ^= 1) then
					start = start - 1;
				     do loop = current_AA to start by -1;
					AA_array.dptr (loop + 1) = AA_array.dptr (loop);
					AA_array.name (loop + 1) = AA_array.name (loop);
					AA_array.last_time (loop + 1) = AA_array.last_time (loop);
				     end;
				     AA_array.dptr (start) = device_ptr;
				     AA_array.name (start) = device.device_name;
				     AA_array.last_time (start) = device.state_time;
				     current_AA = current_AA + 1;
				end;
	end;

/* Now let's see if we have access to any of the AA devices. */
/* The AA_array is sorted with the device used the longest */
/* time ago first.  So they will be checked in order of when */
/* they were used last. */

	found = "0"b;
	do loop = 1 to current_AA while (^found);
	     if have_access (AA_array.name (loop)) then
		found = "1"b;
	end;

/*  If we found one that we have access to then it was also audited in */
/*  rcprm_find_resource_.  If a specific device was not asked for then */
/*  no auditing was needed.  However, if a specific device was requested */
/*  and we did not have access to it then the auditing still needs to be */
/*  done.  It can't be done in rcprm_find_resource_ since that routine has */
/*  no way of knowing if the name it recieves comes from rcp_reserve_ or */
/*  the user.  So we audit it here. */

	if found then
	     dptr = AA_array.dptr (loop - 1);
	else if rsc_name ^= "" then
	     call audit (rsc_name);

     end select_device;

audit:
     proc (P_rsc_name);

dcl	P_rsc_name	   char (*);
dcl	1 auto_event_flags	   like audit_event_flags aligned;

	unspec (auto_event_flags) = ""b;
	auto_event_flags.grant = "0"b;
	auto_event_flags.priv_op = system;
	call access_audit_r1_$log_general ("rcp_reserve_", caller_level, unspec (auto_event_flags),
	     access_operations_$rcp_reserve, (rtrim (rsc_type) || " " || P_rsc_name), (error_table_$reservation_failed),
	     null (), 0);
	return;
     end audit;
%page;
select_volume:
     proc (vptr);

/* Arguments */

dcl	vptr		   ptr;			/* Pointer to the volume entry we eventually select. */
dcl	i		   fixed bin;		/* Index for rcpd. */


	vptr = null;

	if rsc_name = "scratch" then
	     rsc_name = "";

	if ^have_access (rsc_name) then
	     return;				/* Make sure user has access to this volume. */

	do i = 1 to rcpd.last_volume;

	     volume_ptr = addr (rcpd.volume (i));

	     if volume.volume_name = rsc_name & rsc_name ^= "" then do;
		if volume.state = FREE then do;
		     vptr = volume_ptr;
		end;

		else do;
		     vptr = null;
		     return;
		end;
	     end;

	     else do;
		if volume.volume_name = "" & volume.state = FREE then do;
		     if vptr = null then
			vptr = volume_ptr;
		end;
	     end;
	end;

	if vptr = null then do;
	     if rcpd.last_volume < rcpd.tot_volumes then do;
		rcpd.last_volume = rcpd.last_volume + 1;
		vptr = addr (rcpd.volume (rcpd.last_volume));
	     end;
	end;

     end select_volume;

have_access:
     proc (resource_name) returns (bit (1));

dcl	resource_name	   char (*);		/* Name of the resource in question. */

/* Local Variables */

dcl	actual_access	   bit (3);
dcl	local_code	   fixed bin (35);

dcl	addr		   builtin;


	if rcpd.modes.resource_mgmt_enabled then do;
	     special_rdesc_ptr -> resource_descriptions.item (1).name = resource_name;
	     special_rdesc_ptr -> resource_descriptions.item (1).given.name = "1"b;
/**** Set the validation level back up so RCPRM will make the correct access decisions. ****/
	     call cu_$level_set (caller_level);
	     if system then
		call rcprm_find_resource_$reserve_proxy (special_rdesc_ptr, registry_directory, special_resv_ptr,
		     (reserved_for), authorization, local_code);
	     else call rcprm_find_resource_$reserve (special_rdesc_ptr, registry_directory, special_resv_ptr,
		     local_code);
/**** Now set the validation level back so we can get on with our work. ****/
	     call cu_$level_set (get_ring_ ());
	end;
	else do;
	     req_info.user_id = res_for;
	     req_info.current_authorization = authorization;
	     req_info.validation_level = caller_level;
	     res_info.registry_dir = "";
	     res_info.registry_record_ptr, res_info.registry_switch_ptr = null ();
	     res_info.resource_type = rsc_type;
	     res_info.resource_name = resource_name;
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), actual_access, local_code);
	end;

	return (local_code = 0);

     end have_access;

get_attr_values:
     proc;

/*
   This routine takes the caller's attribute string and turns it into
   a form suitable for the rest of RCP.
*/

dcl	mode_idx		   fixed bin;

	model = 0;
	tracks = 0;
	density = "0"b;
	speed = ""b;

	if resource_descriptions.item (i).given.desired_attributes then do;
						/* Use what the user set. */
	     call cv_rcp_attributes_$to_string_rel ((resource_descriptions.item (i).type),
		(resource_descriptions.item (i).desired_attributes (*)), attributes, code);
	     if code ^= 0 then
		goto BAD_ERROR;
	     call mode_string_$parse ((attributes), get_system_free_area_ (), mode_string_info_ptr, code);
	     if code ^= 0 then
		goto BAD_ERROR;

	     do mode_idx = 1 to mode_string_info.number;
		if ^mode_string_info.modes (mode_idx).numeric_valuep then
		     goto BAD_ATTRIBUTE;
		if mode_string_info.modes (mode_idx).mode_name = "model" then
		     call model_mode_proc;
		else if resource_descriptions.item (i).type = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then do;
		     if mode_string_info.modes (mode_idx).mode_name = "track" then
			call track_mode_proc;
		     else if mode_string_info.modes (mode_idx).mode_name = "den" then
			call den_mode_proc;
		     else if mode_string_info.modes (mode_idx).mode_name = "speed" then
			call speed_mode_proc;
		end;
	     end;
	end;					/* Use what the user set. */
	return;

model_mode_proc:
	proc;

	     if model ^= 0 then
		goto BAD_ATTRIBUTE;

	     model = mode_string_info.modes (mode_idx).numeric_value;

	end model_mode_proc;

track_mode_proc:
	proc;

	     if tracks ^= 0 then
		goto BAD_ATTRIBUTE;

	     tracks = mode_string_info.modes (mode_idx).numeric_value;

	end track_mode_proc;

den_mode_proc:
	proc;

dcl	den_conversion_idx	   fixed bin;

dcl	den_conversion_table   (5) fixed bin internal static options (constant) init (200, 556, 800, 1600, 6250);
dcl	density_in_bits	   (5) bit (5) aligned internal static options (constant)
			   init ("10000"b, "01000"b, "00100"b, "00010"b, "00001"b);

	     do den_conversion_idx = lbound (den_conversion_table, 1) to hbound (den_conversion_table, 1)
		while (mode_string_info.modes (mode_idx).numeric_value ^= den_conversion_table (den_conversion_idx));
	     end;
	     if den_conversion_idx > hbound (den_conversion_table, 1) then
		goto BAD_ATTRIBUTE;
	     density = density | density_in_bits (den_conversion_idx);

	end den_mode_proc;

speed_mode_proc:
	proc;

dcl	speed_conversion_idx   fixed bin;

dcl	speed_conversion_table (3) fixed bin internal static options (constant) init (75, 125, 200);

dcl	speed_in_bits	   (3) bit (3) aligned internal static options (constant) init ("100"b, "010"b, "001"b);

	     do speed_conversion_idx = lbound (speed_conversion_table, 1) to hbound (speed_conversion_table, 1)
		while (speed_conversion_table (speed_conversion_idx)
		^= mode_string_info.modes (mode_idx).numeric_value);
	     end;
	     if speed_conversion_idx > hbound (speed_conversion_table, 1) then
		goto BAD_ATTRIBUTE;

	     speed = speed | speed_in_bits (speed_conversion_idx);

	end speed_mode_proc;

     end get_attr_values;

ACCOUNT_WAKEUP:
     procedure (a_devptr, a_action);

/*	This procedure is called to format an accounting message, and send it to the
   *	accounting process.  If the accounting event channel has not been set up, no message is sent.
*/


dcl	a_devptr		   ptr;			/* Pointer to rcp_data entry */
dcl	a_action		   fixed bin;		/* Accounting action */

dcl	wakeup_buf	   fixed bin (71);
dcl	1 auto_rcpamsg	   like rcp_account_msg aligned;

	unspec (auto_rcpamsg) = "0"b;

	auto_rcpamsg.device_user_procid = a_devptr -> device.process_id;
	auto_rcpamsg.rcp_data_relp = rel (a_devptr);
	auto_rcpamsg.devtype = a_devptr -> device.dtypex;
	auto_rcpamsg.action = a_action;

	unspec (wakeup_buf) = unspec (auto_rcpamsg);
	if rcpd.accounting_chan ^= 0 then
	     call hcs_$wakeup (rcpd.accounting_pid, rcpd.accounting_chan, wakeup_buf, (0));

     end ACCOUNT_WAKEUP;

cleanup_handler:
     proc;

/*
   This subroutine will clean up everything and cancel any
   reservations which may have already been made so that the
   reservation of a group of resources can appear as an indivisible
   operation.
*/

/*
   *       Scan through all device and volume entries cleaning up the ones
   *  with the appropriate reservation_id.  We will ignore the group_id
   *  since the reservation_id is assumed to be right.
*/

	call free_storage;
	if any_reserved then do;
	     do i = 1 to rcpd.tot_devices;

		if rcpd.device (i).reservation_id = res_id then do;
		     device_ptr = addr (rcpd.device (i));
		     call admin_gate_$syserr (JUST_LOG, "RCP: Cancelled device ^a for ^a (id=^a)", device.device_name,
			device.group_id, log_res_id);

		     if device.volume_name = "" then
			device.group_id = "";	/* Might be preloaded. */

		     device.reservation_id = 0;
		     device.reserved_by = "";
		     device.process_id = "0"b;
		     device.state_time = clock ();
		     device.state = FREE;
		end;

	     end;

	     do i = 1 to rcpd.last_volume;

		if rcpd.volume (i).reservation_id = res_id then do;
		     volume_ptr = addr (rcpd.volume (i));
		     call admin_gate_$syserr (JUST_LOG, "RCP: Cancelled volume ^a for ^a (id=^a)", volume.volume_name,
			volume.group_id, log_res_id);
		     volume.group_id = "";
		     volume.reservation_id = 0;
		     volume.reserved_by = "";
		     volume.process_id = "0"b;
		     volume.state_time = clock ();
		     volume.state = FREE;
		end;

	     end;
	end;


	if rcpd_ptr ^= null () then
	     call rcp_lock_$unlock (addr (rcpd.lock_info));

	call cu_$level_set (caller_level);

	if callers_resource_res_ptr ^= null () then
	     callers_resource_res_ptr -> reservation_description.reservation_id = 0b;

     end cleanup_handler;

free_storage:
     proc;

	if resource_desc_ptr ^= null () then do;
	     free resource_descriptions;
	     resource_desc_ptr = null ();
	end;
	if resource_res_ptr ^= null () then do;
	     free reservation_description;
	     resource_res_ptr = null ();
	end;
	if mode_string_info_ptr ^= null () then do;
	     free mode_string_info;
	     mode_string_info_ptr = null ();
	end;
	if special_rdesc_ptr ^= null () then do;
	     free special_rdesc_ptr -> resource_descriptions;
	     special_rdesc_ptr = null ();
	end;
	if special_resv_ptr ^= null () then do;
	     free special_resv_ptr -> reservation_description;
	     special_resv_ptr = null ();
	end;

     end free_storage;

copy_resource_and_reservation_structures:
     proc;

/**** Routine to copy the resource and reservation structures from the caller's stack to ours.  It is done
      pretty carefully to ensure that we get a consistent copy (i.e. no fiddling by the caller can cause us
      to screw up). ****/

dcl	based_bits	   (wordcount) bit (36) aligned based;
dcl	wordcount		   fixed bin (21);

	callers_resource_desc_ptr = a_resource_desc_ptr;
	callers_resource_res_ptr = a_resource_res_ptr;
	Resource_count = callers_resource_desc_ptr -> resource_descriptions.n_items;
	wordcount = size (resource_descriptions);
	allocate resource_descriptions in (system_free_area);
	resource_desc_ptr -> based_bits = callers_resource_desc_ptr -> based_bits;
	resource_descriptions.n_items = Resource_count;	/* avoid any tomfoolery on caller's part */
	wordcount = size (reservation_description);
	allocate reservation_description in (system_free_area);
	resource_res_ptr -> based_bits = callers_resource_res_ptr -> based_bits;

     end copy_resource_and_reservation_structures;
%page;
copy_rdesc_and_resv:
     proc ();

	special_rdesc_ptr -> resource_descriptions.n_items = 1;
	special_resv_ptr -> reservation_description.n_items = 1;
	special_rdesc_ptr -> resource_descriptions.version_no = resource_descriptions.version_no;
	special_resv_ptr -> reservation_description.version_no = reservation_description.version_no;
	special_resv_ptr -> reservation_description.reserved_for = reservation_description.reserved_for;
	special_resv_ptr -> reservation_description.reserved_by = reservation_description.reserved_by;
	special_resv_ptr -> reservation_description.reservation_id = reservation_description.reservation_id;
	special_resv_ptr -> reservation_description.group_starting_time = reservation_description.group_starting_time;
	special_resv_ptr -> reservation_description.asap_duration = reservation_description.asap_duration;
	special_resv_ptr -> reservation_description.flags = reservation_description.flags;
     end copy_rdesc_and_resv;
%page;
copy_back_rdesc_and_resv:
     proc (ii);

dcl	ii		   fixed bin;

	resource_descriptions.item (ii) = special_rdesc_ptr -> resource_descriptions.item (1);
	reservation_description.reservation_group (ii) =
	     special_resv_ptr -> reservation_description.reservation_group (1);
     end copy_back_rdesc_and_resv;
%page;
%include access_audit_eventflags;
%page;
%include resource_control_desc;
%page;
%include rcp_com_seg;
%page;
%include rcp_data;
%page;
%include rcp_account_msg;
%page;
%include rcp_resource_types;
%page;
%include rcp_requestor_info;
%page;
%include rcp_resource_info;
%page;
%include rcp_resource_states;
%page;
%include mode_string_info;
%page;
%include syserr_constants;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Reserved device devX_MM for RESERVER (id=RES_ID)

   S:	$log

   T:	$run

   M:	Device devX_MM has been reserved for RESERVER.

   A:	$ignore

  Message:
   RCP: Reserved volume volume_name for RESERVER (id=RES_ID)

   S:	$log

   T:	$run

   M:	Volume volume_name has been reserved for RESERVER.

   A:	$ignore

   Message:
   RCP: An error locking rcpd for reservation for RESERVED_FOR
            by RESERVER [if they're not the same] (id=RES_ID).

   S:	$log

   T:	$run

   M:     An error was found in the locking data for the resource.

   A:	$ignore

   Message:
   RCP: Cancelled device devX_MM for GRP_ID (id=RES_ID)

   S:	$log

   T:	$run

   M:	The reservation for the named device has been cancelled.

   A:	$ignore

   Message:
   RCP: Cancelled volume volume_name for GRP_ID (id=RES_ID)

   S:	$log

   T:	$run

   M:	The reservation for the named volume has been cancelled.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end rcp_reserve_;




		    rcp_resource_info_.pl1          11/11/89  1110.3r   11/11/89  0804.6       39915



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_resource_info_: proc ();


/*
   *
   *   This procedure and its entries constitue the interfaces in RCP to return information to RCPRM from rcp_data.
   *   The entries currently defined are:
   *
   *   current_access_class
   *	returns the current access class of the resource in question.  If it is in use (assigned/reserved)
   *	a pair of bit(1)s are returned to identify who is using the resource.
   *
   *
   *   Initially coded 3/79 by Michael R. Jordan
   *   Modifed during B2 cleanup by Chris Jones to stop using magic numbers.
   *
*/

/*		PARAMETERS		*/


dcl  access_class bit (72) aligned;			/* If in use, the current access class. */
dcl  code fixed bin (35);				/* Error code. */
dcl  in_use bit (1) aligned;				/* ON => Resource is in use (assigned/reserved). */
dcl  in_use_by_other bit (1) aligned;			/* ON => Resource in use by another process. */
dcl  rsc_name char (*);				/* Resource name. */
dcl  rsct char (*);					/* Resource type. */


/*		AUTOMATIC			*/


dcl  device_off bit (18);				/* Offset into rcp_data of device entry. */
dcl  i fixed bin;					/* Temporary index. */
dcl  this_process bit (36);				/* Process id of the current process. */
dcl  vi fixed bin;					/* Volume index. */


/*		ERROR CODES		*/


dcl  error_table_$resource_type_unknown fixed bin (35) ext;
dcl  error_table_$resource_unknown fixed bin (35) ext;


/*		ENTRIES CALLED		*/


dcl  get_process_id_ entry () returns (bit (36));
dcl  rcp_pointers_$data entry () returns (ptr);


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  hbound builtin;
dcl  ptr builtin;

current_access_class: entry (rsct, rsc_name, in_use, in_use_by_other, access_class, code);


/*
   *
   *   This entry tells RCPRM whether a resource is in use and if by another process.
   *
   *   Input parameters are:
   *
   *	(I) rsct -- resource type.
   *	(I) rsc_name -- resource name.
   *	(O) in_use -- ON => resource is assigned/reserved.
   *	(O) in_use_by_other -- ON => resource in use by another process.
   *	(O) access_class -- if in use, the access class.
   *	(O) code -- error code.
   *
   *
*/


	in_use = "0"b;				/* Not in use. */
	in_use_by_other = "0"b;			/* Not in use by anyone. */
	access_class = (72)"0"b;			/* No current access class. */
	code = 0;					/* No error, yet. */

	this_process = get_process_id_ ();

	rcpd_ptr = rcp_pointers_$data ();


/*

   Let's see if this resource type is one of the types we know (and love).

*/


	do i = 1 to hbound (DEVICE_TYPE, 1) ;
	     if rsct = DEVICE_TYPE (i)
	     then do;				/* Found it! */
		do device_off = rcpd.dtype (i).first_off repeat device.next_off while (device_off ^= (18)"0"b);
		     device_ptr = ptr (rcpd_ptr, device_off);
		     if device.device_name = rsc_name
		     then do;
			in_use = (device.state ^= FREE);
			in_use_by_other = in_use & (device.process_id ^= this_process);
			access_class = device.current_authorization;
			return;
		     end;
		end;
		code = error_table_$resource_unknown;
		return;
	     end;
	end;

	do i = 1 to hbound (VOLUME_TYPE, 1);
	     if rsct = VOLUME_TYPE (i)
	     then do;				/* Found the right one. */
		do vi = 1 to rcpd.last_volume;
		     volume_ptr = addr (rcpd.volume (vi));
		     if volume.volume_name = rsc_name
		     & volume.vtypex = i
		     then do;
			in_use = (volume.state ^= FREE);
			in_use_by_other = in_use & (volume.process_id ^= this_process);
			access_class = volume.current_authorization;
			return;
		     end;
		end;
		return;
	     end;
	end;


	code = error_table_$resource_type_unknown ;
	return;

%include rcp_data;
%page;
%include rcp_com_seg;
%page;
%include rcp_resource_types;
%page;
%include rcp_resource_states;

     end rcp_resource_info_;




		    rcp_ring1_init_.pl1             11/11/89  1110.3rew 11/11/89  0805.9      116937



/****^  ***********************************************************
        *                                                         *
        * 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(85-09-11,Fawcett), approve(85-09-11,MCR6979),
     audit(85-12-19,CLJones), install(86-03-21,MR12.0-1033):
     Add MCA support
  2) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
     Correct error message documentation.
                                                   END HISTORY COMMENTS */

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

rcp_ring1_init_: procedure (arg_rif, arg_ecode);

	/*	This program is called to perform RCP initialization during the
   *	initialization of the answering service.  It is called by as_init_.
   *	It will create the RCP directory if it does not already exist.
   *	It will create an ACS for each device that does not already have one.
   *
   *	Created on 05/08/75 by Bill Silver.
   *	Modified on 09/21/77 by R.J.C. Kissel to add the workspace ACS.
   *	Modified on 04/24/78 by Michael R. Jordan to add RCPD modes initialization.
   *	Modified 11/14/78 by C. D. Tavares to add >sss to initializer's search rules for RCPRM use.
   *	Modified 3/79 by Michael R. Jordan for MR7.0R.
   *      Modified 04/79 by CDT for new authentication levels.
   *	Modified 4/82 by E. N. Kittlitz to log error setting search rules. 
   *	Modified 830103 to preassign operator's consoles... -E. A. Ranzenbach
   *      Modified 1984-10-27 by E. Swenson to remove setting of search rules
   *         for ring-1.  In a cold boot, the shutting down and rebooting
   *         which is directed in the installation instructions will get
   *         the ring-1 search rules in order.  In a non-cold boot, the
   *         the search rules will already be those specified as default in
   *         active_hardcore_data.
   *      Modified 1985-03-08, BIM: remove OPC preassignment -- it does
   *         the wrong thing.	         
   *      Modified 1985-04-03, PKF / RAF to add MCA support
*/

	dcl  arg_ecode		     fixed bin (35);		/* (O) error_table_ code. */
	dcl  1 arg_rif		     like rcp_init_flags;		/* pointer to rcp_info in installation parms */

	dcl  rings		     (3) fixed bin (3);		/* Ring brackets for RCP directory. */

	dcl  access		     fixed bin (5);			/* Access to an ACS segment. */
	dcl  caller_level		     fixed bin;			/* Caller's validation level. */
	dcl  dir_name		     char (168);			/* Directory containing the RCP direcotry. */
	dcl  ecode		     fixed bin (35);
	dcl  entryname		     char (32);			/* Entry name of the RCP directory. */
	dcl  group_id		     char (32);			/* Initializer process group ID. */
	dcl  i			     fixed bin;

	dcl  rcp_level		     fixed bin;			/* Current validation level. */
	dcl  syserr_code		     fixed bin;			/* used in calls to syserr. */

	dcl  wkspace_acs		     char (13) aligned internal static options (constant)
				     init ("workspace.acs");

	dcl  (addr, substr, unspec)
				     builtin;

	dcl  cleanup		     condition;

	dcl  (error_table_$no_dir,
	     error_table_$noentry)	     fixed bin (35) external;

	dcl  admin_gate_$syserr	     entry options (variable);
	dcl  admin_gate_$syserr_error_code entry options (variable);
	dcl  cu_$level_get		     entry (fixed bin);
	dcl  cu_$level_set		     entry (fixed bin);
	dcl  expand_pathname_	     entry (char (*), char (*), char (*), fixed bin (35));
	dcl  get_group_id_		     entry returns (char (32));
	dcl  get_ring_		     entry returns (fixed bin);
	dcl  hcs_$append_branch	     entry (char (*) aligned, char (*) aligned, fixed bin (5), fixed bin (35));
	dcl  hcs_$append_branchx	     entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*),
				     fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
	dcl  hcs_$get_user_effmode	     entry (char (*) aligned, char (*) aligned, char (*), fixed bin, fixed bin (5), fixed bin (35));
	dcl  hcs_$set_max_length	     entry (char (*) aligned, char (*) aligned, fixed bin (19), fixed bin (35));
	dcl  rcp_pointers_$com_seg	     entry returns (ptr);
	dcl  rcp_pointers_$data	     entry returns (ptr);
	dcl  rcprm_verify_registries_	     ext entry (char (*), fixed bin (35));

%include access_mode_values;

%include rcp_data;

%include rcp_com_seg;

%include syserr_constants;

	/*	Begin rcp_ring1_init_.pl1
*/

	rcp_level = get_ring_ ();					/* Get RCP's validation level. */
	call cu_$level_get (caller_level);				/* Get caller's validation level. */
	on cleanup begin;						/* If trouble cleanup. */
		call cu_$level_set (caller_level);
	     end;
	call cu_$level_set (rcp_level);				/* Set validation level to RCP level. */


	rcpd_ptr = rcp_pointers_$data ();				/* We need info in rcp_data and rcp_com_seg. */
	rcs_ptr = rcp_pointers_$com_seg ();

	call cu_$level_set (caller_level);				/* Now we have pointers, use caller level. */
	arg_ecode = 0;						/* No bad error code returned. */

	unspec (rcpd.modes) = unspec (arg_rif);

	if rcpd.init then return;					/* already initalized, don't bother */
	group_id = get_group_id_ ();					/* Get this info once. */
	syserr_code = SYSERR_PRINT_WITH_ALARM;				/* Turn on bleeper once. */

	/* First just see if directory is there. */
	call hcs_$get_user_effmode (rcs.acs_directory, rcpd.device (1).acs_name,
	     group_id, caller_level, access, ecode);
	if ecode = error_table_$no_dir				/* Is directory there? */
	then do;							/* No, go create the RCP directory. */
		call CREATE_RCP_DIR;
		if ecode ^= 0
		then goto err_return;
	     end;

	if ^rcpd.modes.resource_mgmt_enabled then
	     do i = 1 to rcpd.tot_devices;				/* Test each device. */
	     device_ptr = addr (rcpd.device (i));
	     call hcs_$get_user_effmode (rcs.acs_directory, device.acs_name, group_id, rcp_level, access, ecode);
	     if ecode = error_table_$noentry				/* Does this ACS exist? */
	     then call CREATE_ACS (device.acs_name);			/* No, we will create it. */
	end;

	call hcs_$get_user_effmode (rcs.acs_directory, wkspace_acs, group_id, rcp_level, access, ecode);

	if ecode = error_table_$noentry				/* Is there a workspace ACS? */
	then call CREATE_ACS (wkspace_acs);				/* No, create it. */

	if rcpd.modes.resource_mgmt_enabled then
	     call rcprm_verify_registries_ (">system_control_1", ecode);
	if ecode ^= 0 then goto err_return;

	if rcpd.modes.resource_mgmt_enabled
	     & rcpd.modes.auto_registration
	     & (rcpd.modes.authentication_level < Automatic_authentication) then
	     call admin_gate_$syserr (SYSERR_PRINT_WITH_ALARM,
		"RCP: Auto registration enabled without strict authentication required.
^8xThis may cause errors in automatic registration of volumes.");
	rcpd.init = "1"b;						/* initialization complete */

	return;

err_return:
	arg_ecode = ecode;
	return;

	/* 	*/
CREATE_RCP_DIR: procedure;

	/*	This procedure is called to create the RCP directory that will contain
   *	the Access Control Segments for each device.   The default access to
   *	this directory will be taken from the initial directory ACL of the
   *	containing directory.  In addition all users will be given S access.
*/
	call expand_pathname_ ((rcs.acs_directory), dir_name, entryname, ecode);
	if ecode ^= 0
	then do;
		call admin_gate_$syserr_error_code (SYSERR_PRINT_WITH_ALARM, ecode, "RCP: Error expanding ^a:", rcs.acs_directory);
		return;
	     end;

	rings (*) = 7;
	call hcs_$append_branchx (dir_name, entryname, S_ACCESS_BIN, rings, "*.*.*", 1, 0, 0, ecode);
	if ecode ^= 0
	then do;
		call admin_gate_$syserr_error_code (SYSERR_PRINT_WITH_ALARM, ecode, "RCP: Error creating ^a:", rcs.acs_directory);
		return;
	     end;

	call admin_gate_$syserr (SYSERR_PRINT_WITH_ALARM, "RCP: Created ^a with default access.", rcs.acs_directory);

	syserr_code = SYSERR_PRINT_ON_CONSOLE;				/* Only turn on bleeper once. */

     end CREATE_RCP_DIR;

	/* 	*/
CREATE_ACS: procedure (acs_name);

	/*	This procedure is called to create an ACS for the current device.
   *	The default access to this device will be RW for the current process.
   *	In addition to creating the ACS we will set the max segment length
   *	of this segment to 0.
*/

	dcl  acs_name		     char (*) aligned;		/* name of the segment to create. */

	call cu_$level_get (caller_level);
	if substr (acs_name, 1, 3) = "mca" then do;
		rcp_level = get_ring_ ();

		on cleanup begin;
			call cu_$level_set (caller_level);
		     end;
		call cu_$level_set (rcp_level);
		rings (*) = 1;					/* must be in ring 1 */
		call hcs_$append_branchx ((rcs.acs_directory), (acs_name), RW_ACCESS_BIN, rings, "", 0, 0, 0, ecode);
		if ecode ^= 0
		then do;
			call admin_gate_$syserr_error_code (SYSERR_PRINT_WITH_ALARM, ecode, "RCP: Error creating ACS ^a:", acs_name);
			goto CREATE_ACS_EXIT;
		     end;

		call admin_gate_$syserr (syserr_code, "RCP: Created ^a>^a with default access.",
		     rcs.acs_directory, acs_name);

		call hcs_$set_max_length (rcs.acs_directory, acs_name, 0, ecode);
		if ecode ^= 0
		then call admin_gate_$syserr_error_code (SYSERR_PRINT_WITH_ALARM, ecode, "RCP: Error setting max length of ^a:", acs_name);

		goto CREATE_ACS_EXIT;
	     end;
	else do;
		call hcs_$append_branch (rcs.acs_directory, acs_name, RW_ACCESS_BIN, ecode);
		if ecode ^= 0
		then do;
			call admin_gate_$syserr_error_code (SYSERR_PRINT_WITH_ALARM, ecode, "RCP: Error creating ACS ^a:", acs_name);
			goto CREATE_ACS_EXIT;
		     end;

		call admin_gate_$syserr (syserr_code, "RCP: Created ^a>^a with default access.",
		     rcs.acs_directory, acs_name);

		call hcs_$set_max_length (rcs.acs_directory, acs_name, 0, ecode);
		if ecode ^= 0
		then call admin_gate_$syserr_error_code (SYSERR_PRINT_WITH_ALARM, ecode, "RCP: Error setting max length of ^a:", acs_name);
	     end;

CREATE_ACS_EXIT:

	syserr_code = SYSERR_PRINT_ON_CONSOLE;				/* Turn on bleeper only once. */
	call cu_$level_set (caller_level);

     end CREATE_ACS;

%page;

	/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Error expanding DIR: ERROR_MESSAGE

   S:	$beep

   T:	$run

   M:	The pathname of the acs directory is incorrect. It should be >system_control_1>acs.
   $err
   The system may be unable to use I/O devices.

   A:	$contact


   Message:
   RCP: Error creating DIR: ERROR_MESSAGE

   S:	$beep

   T:	$run

   M:	The system was unable to create the ACS directory.
   It should be >system_control_1>acs.
   The system may be unable to use I/O devices.

   A:	$contact


   Message:
   RCP: Created DIR with default access.

   S:	$beep

   T:	$run

   M:	The directory (usually >system_control_1>rcp) was created
   because it was not found at startup.
   It may have been destroyed in a crash.
   This message is normal during a cold boot of the Multics hierarchy.

   A:	If users other than system processes should have access to the directory,
   the system administrator must set the ACL appropriately.


   Message:
   RCP: Error creating ACS DEVICE.acs: ERROR_MESSAGE

   S:	$beep

   T:	$run

   M:	The system was unable to create an access control segment for DEVICE.
   No user will be able to attach it.

   A:	$contact


   Message:
   RCP: Created DIR>DEVICE.acs with default access.

   S:	$beep

   T:	$run

   M:	The system has created an access control segment for DEVICE
   because one was not found at startup.
   It may have been destroyed in a crash.
   This message is normal during the first use of a device on the system, and at cold boot.

   A:	If users other than system processes should have access to DEVICE,
   the system administrator must set the ACL of DEVICE.acs appropriately.


   Message:
   RCP: Error setting max length of DEVICE.acs: ERROR_MESSAGE

   S:	$beep

   T:	$run

   M:	$err

   A:	$contact

   Message:
   RCP: Auto Registration is enabled without Exact Authentication required.  This could lead to errors in automatic registration of volumes.

   S:	$beep

   T:	$run

   M:	This is a warning.  If the system is operated with auto registration enabled and exact authentication
   of tape volumes is not required, there is a better chance of errors occurring in the registration of tape
   volumes.  Again, it is very important to make sure the volume mounted is the proper one
   for the request if auto registration is enabled.

   A:	$ignore


   END MESSAGE DOCUMENTATION */

     end rcp_ring1_init_;




		    rcp_set_lock_.pl1               11/11/89  1110.3rew 11/11/89  0805.2       79524



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


rcp_set_lock_:  procedure;

/*	rcp_set_lock_ taken from set_lock_.
*	Will be made into the real set_lock_ later.
*/
/*	set_lock_ - This procedure allows a user to guarantee that two processes
		will not simultaneously execute the same critical section of code.
		A user provided lock word can be set to the lock identifier of
		only one process at a time thereby guaranteeing, assuming the proper
		conventions are followed, that only this process can be currently
		executing in the critical section of code.

	Originally coded by R. J. Feiertag on November 5, 1971
	Modified on April 6, 1972 by R. J. Feirtag to work in all rings.
	Modified on October 1, 1974 by J. Stern to eliminate message segment metering.
	Modified on December 7, 1974 by Bill Silver to add generalized metering.
*/

dcl	arg_code		fixed bin(35);	/* (O) error_table_ code. */
dcl	arg_lock		bit(36)  aligned;	/* (I) The lock to lock or unlock. */
dcl	arg_time_of_lock	fixed bin(71);	/* (I/O) Raw time lock locked. */
dcl	arg_time_locked	fixed bin(71);	/* (O) Raw time (duration) lock was locked. */
dcl	arg_time_waiting	fixed bin(71);	/* (O) Raw time waiting for lock. */
dcl	arg_wait_time	fixed bin;	/* (I) Time in seconds to wait for lock. */

	dcl lock_ptr ptr,	/* Pointer to lock. */
	    wait_time fixed bin, /* time in seconds to wait for lock to be unlocked */
	    code fixed bin(35), /* indicates success of call */
	    time_locked fixed bin(71), /* time locked locked. */
	    time_started fixed bin(71), /* time we started to wait for lock. */
	    alarm_time fixed bin(71), /* saved value of alarm timer */
	    alarm_channel fixed bin(71), /* saved value of alarm timer channel */
	    message(4) fixed bin(71), /* message from ipc */
	    failure_time fixed bin(71) init(0), /*  is the time at which this call will give up */
	    sleep_time fixed bin(71), /* is the number of microseconds until this call gives up */
	    ttul_code fixed bin, /* is the status from try_to_unlock_lock */
	    lock_id bit(36) aligned internal static init(""b); /* is the lock identifier of this process */

	dcl based_lock  bit(36) aligned  based(lock_ptr);

	dcl 1 wait_list aligned internal static, /* list of channels to wait on for ipc */
		2 channel_count fixed bin init(1), /* number of channels to wait on */
		2 channel fixed bin(71) init(0); /* channel for waiting */

	dcl error_table_$locked_by_other_process ext fixed bin(35),
	    error_table_$locked_by_this_process ext fixed bin(35),
	    error_table_$lock_not_locked ext fixed bin(35),
	    error_table_$invalid_lock_reset ext fixed bin(35),
	    error_table_$lock_wait_time_exceeded ext fixed bin(35);

	dcl get_lock_id_ ext entry(bit(36) aligned),
	    get_ring_ ext entry returns(fixed bin(3)),
	    get_initial_ring_ ext entry returns(fixed bin(3)),
	    ipc_$create_ev_chn ext entry(fixed bin(71),fixed bin(35)),
	    ipc_$block ext entry(ptr,ptr,fixed bin(35)),
	    stacq ext entry(ptr,bit(36) aligned,fixed bin(35)) returns (bit(1) aligned),
	    hcs_$get_alarm_timer ext entry(fixed bin(71),fixed bin(71)),
	    hcs_$set_alarm_timer ext entry(fixed bin(71),fixed bin,fixed bin(71)),
	    hcs_$try_to_unlock_lock ext entry(ptr,fixed bin),
	    clock_ ext entry returns(fixed bin(71)),
	    timer_manager_$sleep ext entry(fixed bin(71),bit(2));

	dcl (stac,min,addr) builtin;
/*	*/
/*	This entry attempts to set the lock word to the lock indentifier of the
*	calling process.  If the lock is already set by some other existing process
*	then it waits for some given period of time for the lock to be unlocked.
*	If the lock is not unlocked in the given time then set_lock_ gives up and returns.
*/
lock:  entry  (arg_lock,arg_wait_time,arg_code);

	lock_ptr = addr(arg_lock);		/* Get pointer to lock to lock. */
	wait_time = arg_wait_time;

	call LOCK;			/* Try to lock lock. */

	arg_code = code;
	return;





/*	This entry performs the same function as unlock except that it allows the
*	caller to perform metering on the lock.
*/
meter_lock:  entry  (arg_lock,arg_wait_time,arg_time_of_lock,arg_time_waiting,arg_code);

	lock_ptr = addr(arg_lock);		/* Get pointer to lock to lock. */
	wait_time = arg_wait_time;
	time_started = 0;			/* Initialize time waiting started. */

	call LOCK;			/* Try to lock the lock. */

	if   (code = 0)  |			/* Was lock set OK? */
	     (code = error_table_$invalid_lock_reset)
	     then do;			/* Yes, compute meters. */
		time_locked = clock_();
		if   time_started = 0
		     then time_started = time_locked;
	     end;
	     else do;			/* No, lock not locked. */
		time_locked,
		time_started = 0;
	     end;

	arg_time_of_lock = time_locked;	/* Return meter data. */
	arg_time_waiting = time_locked - time_started;
	arg_code = code;
	return;
/**/
LOCK:  procedure;

/*	This procedure is called to try to lock the lock.
*/

	if lock_id = ""b then call get_lock_id_(lock_id); /* get lock id if we don't already have it */
AGAIN:
	if stac(lock_ptr,lock_id) then do; /* locked successfully, we are done */
		code = 0; /* return successful code */
		return;
		end;
	call hcs_$try_to_unlock_lock(lock_ptr,ttul_code);
	if ttul_code = 3 then do; /* lock was invalid and was relocked */
		code = error_table_$invalid_lock_reset; /* return successful code */
		return;
		end;
	if time_started = 0 then time_started = clock_();
	if ttul_code = 2 then go to AGAIN; /* lock is not locked, try again */
	if based_lock = lock_id then do; /* already locked by this process */
		code = error_table_$locked_by_this_process;
		return;
		end;
	if failure_time = 0 then /* calculate when we will give up */
	 if wait_time < 0 then  /*  largest possible clock time */
	  failure_time = /* 2**52 */ 10000000000000000000000000000000000000000000000000000b;
	  else failure_time = clock_() + wait_time * 1000000; /* calculate time to give up */
	sleep_time = failure_time - clock_(); /* calculate time to sleep */
	if sleep_time <= 0 then do; /* time to give up */
		code = error_table_$lock_wait_time_exceeded; /* return unsuccessful code */
		return;
		end;
	if get_ring_() >= get_initial_ring_() then /* we can call timer_manager_ */
	 call timer_manager_$sleep(min(sleep_time,2000000),"10"b); /* sleep for some time */
	 else do; /* we cannot call timer_manager_ */
		if channel = 0 then do; /* a channel must be created */
			call ipc_$create_ev_chn(channel,code); /* create the channel */
			if code ^= 0 then return; /* if trouble then forget it */
			end;
		call hcs_$get_alarm_timer(alarm_time,alarm_channel); /* remember current alarm settings */
		call hcs_$set_alarm_timer(min(sleep_time,1000000),1,channel); /* get awakened later */
		call ipc_$block(addr(wait_list),addr(message),code); /* wait for wakeup */
		call hcs_$set_alarm_timer(alarm_time,2,alarm_channel); /* reset original timer settings */
		if code ^= 0 then return; /* if trouble then give up */
		end;
	go to AGAIN; /* try again */
	end  LOCK;
/**/
/*	This entry attempts to unlock the lock.
*/
unlock:  entry  (arg_lock,arg_code);

	lock_ptr = addr(arg_lock);		/* Get pointer to lock. */

	call UNLOCK;			/* Try to unlock lock. */

	arg_code = code;			/* Return error code. */
	return;





/*	This entry performs the same function as unlock except that it also
*	returns metering data.
*/
meter_unlock:  entry  (arg_lock,arg_time_of_lock,arg_time_locked,arg_code);

	lock_ptr = addr(arg_lock);		/* Get pointer to lock. */

	call UNLOCK;			/* Try to unlock lock. */

	if   code = 0			/* Was locked unlocked OK? */
	     then arg_time_locked = clock_() - arg_time_of_lock;
	     else arg_time_locked = 0;	/* No. */
	arg_code = code;
	return;





UNLOCK:  procedure;

/*	This procedure is called to try to unlock the lock.
*/

	if lock_id = ""b then call get_lock_id_(lock_id); /* get lock id if we don't already have it */
	if ^stacq(lock_ptr, lock_id, 0) then /* lock was not locked by this process */
		if based_lock = ""b then code = error_table_$lock_not_locked;
					/* lock was not locked */
		 else code = error_table_$locked_by_other_process;
					/* lock was set by another process */
	 else code = 0; /* everything OK - lock was locked by us and cleared by stacq */
	end  UNLOCK;

	end  rcp_set_lock_;




		    rcp_setup_event.pl1             11/11/89  1110.3r   11/11/89  0805.5       46404



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */
/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcp_setup_event:
     proc (a_operation, a_effmode, a_event_flag, a_error_code);

/*            This internal subroutine sets up the event flag
   *          structure needed to determine if auditing of the
   *	    event is required.
   *
   *            Created 850221 by Maria M. Pozzo
   *
*/

/*            ARGUMENT DATA                     */

dcl	a_operation	   bit (36) aligned;	/* (I) The RCP operation */
dcl	a_priv_gate_call	   bit (1);		/* (I) "1"b if the call was made from rcp_sys_, rcp_admin_, rcp_priv_. */
dcl	a_effmode		   bit (3);		/* (I) The resulting effective mode of the subject to the resource. */
dcl	a_event_flag	   bit (36) aligned;	/* (O) Pointer to the event_flag structure. */
dcl	a_error_code	   fixed bin (35);		/* (O) Error code. */

/*            AUTOMATIC DATA                    */

dcl	effmode		   bit (3);

dcl	operation		   bit (36) aligned;
dcl	base_op		   bit (36) aligned;

dcl	local_code	   fixed bin (35);

dcl	event_ptr		   ptr;
dcl	operation_ptr	   ptr;

dcl	1 en_access_op	   like encoded_access_op aligned based (operation_ptr);

/*                    EXTERNAL ENTRIES                        */

dcl	access_operations_$rcp_register
			   bit (36) aligned external;
dcl	access_operations_$rcp_deregister
			   bit (36) aligned external;
dcl	access_operations_$rcp_register_acquire
			   bit (36) aligned external;
dcl	access_operations_$rcp_preload
			   bit (36) aligned external;
dcl	access_operations_$rcp_set_access
			   bit (36) aligned external;
dcl	access_operations_$rcp_clear
			   bit (36) aligned external;
dcl	access_operations_$rcp_unassign
			   bit (36) aligned external;
dcl	access_operations_$rcp_add_device
			   bit (36) aligned external;
dcl	access_operations_$rcp_delete_device
			   bit (36) aligned external;
dcl	access_operations_$rcp_copy_registry
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_delete_registry
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_reconstruct_registry
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_update_registry_header
			   bit (36) aligned ext static;

/*  Copy arguments */

	operation = a_operation;
	base_op = operation;
	addr (base_op) -> en_access_op.detailed_operation = 0;
	ops_ptr = addr (addr (operation) -> en_access_op.detailed_operation);
	effmode = a_effmode;
	event_ptr = addr (a_event_flag);
	local_code = 0;

	event_ptr -> audit_event_flags.special_op = special ();
	event_ptr -> audit_event_flags.admin_op = admin ();
	event_ptr -> audit_event_flags.priv_op = priv ();
	event_ptr -> audit_event_flags.grant = (effmode ^= "000"b);
	event_ptr -> audit_event_flags.cc_1_10 = "0"b;
	event_ptr -> audit_event_flags.cc_10_100 = "0"b;

MAIN_RETURN:
	a_error_code = local_code;

	return;
%page;
special:
     proc () returns (bit (1));

/* Operations which change the access class range of the object are special. */
/* Operations which change the acs_path are also special. */

	if base_op = access_operations_$rcp_set_access then
	     return ("1"b);
	else return ("0"b);

     end special;
%page;
admin:
     proc () returns (bit (1));

/* Operations that can only be called from rcp_sys_, rcp_admin_ or */
/* rcp_priv_. */

	if (base_op = access_operations_$rcp_unassign & (detailed_operation.force | detailed_operation.process)) then
	     return ("1"b);
	if base_op = access_operations_$rcp_add_device | base_op = access_operations_$rcp_delete_device then
	     return ("1"b);
	if base_op = access_operations_$rcp_preload then
	     return ("1"b);
	if base_op = access_operations_$rcp_register | base_op = access_operations_$rcp_register_acquire
	     | base_op = access_operations_$rcp_deregister then
	     return ("1"b);
	if base_op = access_operations_$rcp_clear then
	     return ("1"b);
	if base_op = access_operations_$rcp_copy_registry | base_op = access_operations_$rcp_delete_registry
	     | base_op = access_operations_$rcp_reconstruct_registry
	     | base_op = access_operations_$rcp_update_registry_header then
	     return ("1"b);

	return ("0"b);

     end admin;
%page;
priv:
     proc () returns (bit (1));

/* Standard operations that are called with a -priv or other argument */
/* that causes them to be invoked through a privileged gate.          */
/* ADMIN operations are invoked through a privileged gate as well and */
/* they are considered to be PRIV operations also.                    */

	if detailed_operation.priv_gate_call then
	     return ("1"b);
	else return ("0"b);

     end priv;
%page;
%include access_audit_encoded_op;
%page;
%include rcp_ops;
%page;
%include access_audit_eventflags;

     end rcp_setup_event;




		    rcp_tape_.pl1                   11/11/89  1110.3rew 11/11/89  0807.1      406584



/****^  ***********************************************************
        *                                                         *
        * 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(85-10-14,Farley), approve(85-10-14,MCR6979),
     audit(85-12-17,CLJones), install(86-03-21,MR12.0-1033):
     Issue request_status
     to FIPS devices. Allow for long unload connect time for FIPS.
  2) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
     Correct error message documentation.
  3) change(86-12-03,GWMay), approve(86-12-03,PBF7552),
     audit(86-12-09,Martinson), install(86-12-17,MR12.0-1250):
     Changed to go ahead and read the tape label so that the caller can display
     the "real" id and density of the tape when being run as the Initializer or
     if the authentication_level installation parameter is set to none.
  4) change(86-12-23,GDixon), approve(86-12-23,PBF7552),
     audit(86-12-23,Farley), install(87-01-05,MR12.0-1253):
     Don't change caller's volume label when rcp_tape_ was unable to read a
     label from the tape.  Set automatic write_flag in TAPE_STATE(4).
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,ifthen */
rcp_tape_:
     procedure (arg_rcse_ptr, arg_ecode);

/*	This program is an internal interface of RCP.
   *	Created on 02/20/75 by Bill Silver.
   *	Changed on 11/01/76 by Bill Silver to set/reset mount timer.
   *	Changed on 09/19/77 by R.J.C. Kissel to check tape labels.
   *	Modified on 04/26/78 by Michael R. Jordan to allow preloaded tape volumes.
   *	Modified on 01/31/79 by Michael R. Jordan to return label and density info,
   *	  to stop label reading on manual halt.
   *	Modified 4/79 by R.J.C. Kissel to handle 6250 bpi tapes.
   *	Modified 3/79 by Michael R. Jordan for MR7.0R
   *	Modified 04/79 by C. D. Tavares tor internal label authentication.
   *	Modified 01/02/81 by J. A. Bush for bootable Multics standard tapes
   *	Modified 3/82 by R.J.C. Kissel for FIPS level 1 by checking the accessibility code in an ANSI label
   *	Modified 7/82 by B. Braun to check 32 chars of the tape label and not just the first 16 characters.
   *                See TRs phx13431, phx12222.
   *	Modified 1/83 by J. A. Bush the set the rcse.label_type directly from the workspace
   *      Modified 12/83 by B. Braun to correct unnecessary authentication of tapes (phx14557 phx14837 phx16233).
   *	Modified 11/84 by Paul Farley to issue request_status to FIPS devices
   *	instead of set_write_permit, because the latter is not supported.
   *	Modified 10/85 by Paul Farley to extend the default IOI timeout during
   *	an unload of a FIPS tape to include a possible full rewind time.
   *
   *	This program is called to perform special tape attachment processing.
*/

/*		ARGUMENT  DATA		*/

dcl  arg_ecode fixed bin (35);			/* (O) Return error_table_ code. */
dcl  arg_rcse_ptr ptr;				/* (I) Pointer to attachment RCS entry. */


/*		AUTOMATIC  DATA		*/

dcl  command bit (6);				/* Initial IDCW command to device. */
dcl  device_off bit (18) aligned;			/* RCPD device entry offset. */
dcl  drive_num fixed bin;				/* Tape drive number. */
dcl  (ecode, scode) fixed bin (35);			/* error_table_ code. */
dcl  ioi_index fixed bin;				/* IOI internal device index. */
dcl  special_status_bits bit (7) aligned;		/* Used to isolate the special status bits we need. */
dcl  users_requested_volume_name char (32);
dcl  workspace_ptr ptr;				/* Pointer to our workspace. */
dcl  write_flag bit (1) aligned;


/*		BASED  DATA		*/

dcl  1 wspace based (workspace_ptr) aligned,		/* Overlay of IOI workspace. */
       2 idcw bit (36),				/* Tape IDCW. */
       2 read_idcw bit (36),
       2 read_dcw bit (36),
       2 rewind_idcw bit (36),
       2 state fixed bin,				/* Index that => current state of attachment. */
       2 get_authentication_state fixed bin,
       2 read_label_state fixed bin,
       2 read_record_state fixed bin,
       2 rewind_state fixed bin,
       2 set_density_state fixed bin,
       2 tape_state_4_state fixed bin,
       2 mount_state fixed bin,			/* Save state used to wait for mounts. */
       2 i fixed bin,				/* read_label loop counter. */
       2 j fixed bin,				/* read_record loop counter. */
       2 retry_count fixed bin,			/* Number of REREADYs we have issued. */
       2 ring_comment char (8),			/* Used in tape mount messages. */
       2 special_flag bit (1),			/* ON => special interrupt. */
       2 special_status_word bit (36),			/* One word of special status. */
       2 label_name char (32) unaligned,		/* label read from tape. */
       2 label_type fixed bin,			/* see label_msg below for meaning. */
       2 flags,
         (
         3 bad_mode bit (1),
         3 blank_tape bit (1),
         3 den_set bit (1),
         3 nrzi_den_set bit (1),
         3 label_match bit (1),
         3 unreadable_tape bit (1),
         3 record_read bit (1),
         3 wait bit (1),
         3 manual_halt bit (1),
         3 ansi_non_blank_access bit (1),
         3 pad bit (26)
         ) unaligned,
       2 pad_ptr ptr,				/* Pad so status queue starts at even offset. */
       2 istatq like istat,				/* Our status queue - only 1 entry. */
       2 label_buffer (32) bit (36);			/* Place to put the first few words for label checking. */


/*		INTERNAL STATIC DATA	*/

dcl  max_num_retries fixed bin options (constant)		/* Number of times we will ready a tape drive. */
	internal static init (5);

dcl  template_idcw bit (36) options (constant) /* Template of the IDCW we will use. */ internal static
	init ("000000700201"b3);

dcl  template_read_idcw bit (36) options (constant) internal static init ("050000700000"b3);
						/* Read record binary command. */

dcl  template_read_dcw bit (36) options (constant) internal static init ("000000000000"b3);
						/* We will set the address and tally later. */

dcl  template_rewind_idcw bit (36) options (constant) internal static init ("700000700201"b3);

dcl  rewind_command bit (6) options (constant) /* IDCW command. */ internal static init ("70"b3);

dcl  rewind_unload_command bit (6) options (constant) /* IDCW command. */ internal static init ("72"b3);

dcl  reset_status_command bit (6) options (constant) /* IDCW command. */ internal static init ("40"b3);

dcl  request_status_command bit (6) options (constant) /* IDCW command. */ internal static init ("00"b3);

dcl  set_write_permit_command bit (6) options (constant) /* IDCW command. */ internal static init ("63"b3);

dcl  density (5) bit (6) options (constant) /* Set density commands */ internal static
	init ("60"b3, "61"b3, "64"b3, "65"b3, "41"b3);	/* 800, 556, 200, 1600, and 6250 bpi */

dcl  DENSITY_INDEX (5) fixed bin options (constant) /* Volume density index */ internal static init (3, 2, 1, 4, 5);
						/* 800, 556, 200, 1600, 6250 */

dcl  FIPS_UNLOAD_TIMEOUT fixed bin (71) options (constant) /* MAX time for connect */ internal static init (90000000);


/*		EXTERNAL ENTRIES CALLED	*/

dcl  (addr, fixed, null, rel, size, substr, bin, ptr, dim, translate) builtin;
dcl  (bit, collate9, divide, hbound, lbound, length, min) builtin;

dcl  (
     error_table_$action_not_performed,
     error_table_$device_attention,
     error_table_$invalid_state
     ) fixed bin (35) external;

dcl  admin_gate_$ioi_set_to_max entry (fixed bin, fixed bin (71), fixed bin (35));
dcl  admin_gate_$syserr entry options (variable);
dcl  cv_dec_ entry (char (*), fixed bin);
dcl  ioi_$connect entry (fixed bin, fixed bin, fixed bin (35));
dcl  ioi_$get_special_status entry (fixed bin, bit (1) aligned, bit (36) aligned, fixed bin (35));
dcl  ioi_$set_status entry (fixed bin, fixed bin (18), fixed bin, fixed bin (35));
dcl  ioi_$timeout entry (fixed bin, fixed bin (71), fixed bin (35));
dcl  ioi_$workspace entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  rcp_auto_register_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  rcp_ioi_attach_ entry (ptr, fixed bin (35));
dcl  rcp_mount_timer_$reset entry (bit (18) aligned, fixed bin (35));
dcl  rcp_mount_timer_$set entry (bit (18) aligned, bit (1) aligned, fixed bin (35));
dcl  rcp_pointers_$data entry () returns (ptr);
dcl  bcd_to_ascii_ entry (bit (*), char (*));
dcl  ebcdic8_to_ascii_ entry (bit (*), char (*));
dcl  canon_for_volume_label_ entry (char (*), char (*), char (*), fixed bin, fixed bin (35));
dcl  authenticate_ ext entry (char (*)) returns (char (3) aligned);

%include rcp_com_seg;

%include rcp_data;

%include rcp_volume_formats;

%include iom_pcw;

%include iom_dcw;

%include ioi_stat;

%include iom_stat;

%include resource_control_desc;

%include rcp_resource_types;

%include mstr;


/*	Begin special tape attachment processing.
*/
	rcse_ptr = arg_rcse_ptr;			/* Copy argument. */
	rcs_ptr = ptr (rcse_ptr, "0"b);

	rcpd_ptr = rcp_pointers_$data ();

	workspace_ptr = rcse.workspace_ptr;		/* Get pointer to current workspace. */
	ecode = 0;

	if workspace_ptr ^= null ()			/* Have we set up a workspace yet? */
	then do;					/* Yes. */
	     ioi_index = rcse.ioi_index;		/* We will need this to call IOI. */
	     isp = addr (wspace.istatq);		/* Almost every state needs this pointer. */
	     goto TAPE_STATE (wspace.state);		/* Go do next step in tape attachment. */
	end;


/*	No workspace implies that this is the first call to rcp_$check_attach.
   *	We must attach the tape drive in ring 0 via IOI.
*/
	call rcp_ioi_attach_ (rcse_ptr, ecode);
	if ecode ^= 0				/* Now check for any error at all. */
	then do;					/* Yes, abort attachment. */
	     arg_ecode = ecode;
	     return;
	end;
	ioi_index = rcse.ioi_index;			/* Get IOI index for this attachment. */

/*	We have just attached the tape drive to IOI.  We must get an IOI workspace.
   *	Then we will try to unload any volume mounted on this tape drive.
   *	For T&D attachments we don't want to do any of this special processing.
*/
	if rcse.flags.t_and_d			/* Is this a special T&D attachment? */
	then do;					/* Yes, nothing to do. */
	     rcse.state = 4;			/* Tell caller that tape is ready for use. */
	     arg_ecode = 0;
	     return;
	end;

	call ioi_$workspace (ioi_index, workspace_ptr, size (wspace), ecode);
	if ecode ^= 0 then do;
	     arg_ecode = ecode;
	     return;
	end;

	rcse.workspace_ptr = workspace_ptr;		/* Save workspace pointer for this attachment. */
	wspace.idcw = template_idcw;			/* Set up template IDCWs. */
	wspace.read_idcw = template_read_idcw;
	wspace.read_dcw = template_read_dcw;
	wspace.rewind_idcw = template_rewind_idcw;
	call cv_dec_ (substr (rcse.device_name, 6, 2), drive_num);

/* Set the device code in the IDCWs. */

	addr (wspace.idcw) -> idcw.device = bit (fixed (drive_num, 6));
	addr (wspace.read_idcw) -> idcw.device = bit (fixed (drive_num, 6));
	addr (wspace.rewind_idcw) -> idcw.device = bit (fixed (drive_num, 6));

/* Set the buffer address and a tally count in the read DCW. */

	addr (wspace.read_dcw) -> dcw.address = rel (addr (wspace.label_buffer));
	addr (wspace.read_dcw) -> dcw.tally = bit (bin (dim (wspace.label_buffer, 1), 12), 12);
	wspace.state,				/* Initialize the state variable that controls all. */
	     wspace.mount_state, wspace.retry_count = 0;	/* Initialize retry count. */
	if rcse.flags.writing			/* Set up mount comment. */
	     then
	     wspace.ring_comment = "with";
	else wspace.ring_comment = "without";

	isp = addr (wspace.istatq);			/* Call IOI to set up our status queue. */
	call ioi_$set_status (ioi_index, fixed (rel (isp), 18), 1, ecode);
	if ecode ^= 0 then do;			/* Can't go on without a status queue. */
	     arg_ecode = ecode;
	     return;
	end;

	if rcse.flags.preloaded then do;
	     wspace.state = 2;
	     wspace.mount_state = 2;
	     command = rewind_command;
	end;
	else do;

/*	If we are unloading a FIPS tape drive, then we need to allow for the
   *	case where a rewind is in progress and the FIPS adapter holds onto the
   *	unload connect till the rewind completes. This is because the tape
   *	subsystem does not allow the unload, because the rewind has it busy.
*/
	     if rcse.flags.fips then do;
		call admin_gate_$ioi_set_to_max (ioi_index, FIPS_UNLOAD_TIMEOUT, ecode);
		if ecode ^= 0 then do;
		     arg_ecode = ecode;
		     return;
		end;
		call ioi_$timeout (ioi_index, FIPS_UNLOAD_TIMEOUT, ecode);
		if ecode ^= 0 then do;
		     arg_ecode = ecode;
		     return;
		end;
	     end;
	     wspace.state = 1;
	     command = rewind_unload_command;
	end;

	istat.completion.st = "0"b;			/* Try to rewind or rewind and unload the current volume. */
	addr (wspace.idcw) -> idcw.command = command;
	call ioi_$connect (ioi_index, 0, ecode);
	arg_ecode = ecode;
	return;


/*	Somehow or other we are trying to use the workspace out of sequence.
*/
TAPE_STATE (0):					/* INVALID STATE */
	arg_ecode = error_table_$invalid_state;
	return;


/*	The connect issued to perform the rewind & unload has terminated.
   *	We don't really care whether or not the rewind & unload operation worked.
   *	We will tell the operator to mount the tape volume being attached.
   *	Then we will wait for any special interrupts generated by a rewind & unload
   *	or the mounting.
*/
TAPE_STATE (1):					/* REWIND & UNLOAD TERMINATION */
	if ^istat.completion.st			/* There should at least be some status. */
	     then
	     return;				/* None, so ignore. */
						/* REQUEST TAPE MOUNT */
	call Print_Mount_Message ();			/* Print a mount message for the operator. */
	wspace.state,				/* Wait for special from tape mounting. */
	     wspace.mount_state = wspace.state + 1;	/* Remember state used to wait for mount. */
						/* Turn ON the mount timer. */
	device_off = rcse.device_off;			/* Need RCPD device entry offset. */
	write_flag = rcse.flags.writing;		/* Pass on write flag. */
	call rcp_mount_timer_$set (device_off, write_flag, ecode);
	arg_ecode = ecode;
	return;


/*	We should come here because we have received a special interrupt.
   *	We will check to see if it is from a rewind & unload or from
   *	a mount.  The special status bits we will test are:
   *	REWIND, UNLOAD, READY, STANDBY, LOADED, RELEASED, MALFUNCTIONED.
*/
TAPE_STATE (2):					/* SPECIAL from REWIND, REWIND & UNLOAD or from MOUNT. */
	call ioi_$get_special_status (ioi_index, special_flag, special_status_word, ecode);
	if (ecode ^= 0) then do;
	     arg_ecode = ecode;
	     return;
	end;
	if ^special_flag then
	     if rcse.flags.preloaded then do;		/* No special and we thought the tape was there, ask for it */
		if ^istat.completion.st then do;	/* REWIND has not been processed yet, just wait a while */
		     arg_ecode = 0;
		     return;
		end;
		if istat.completion.er | /* If there was an error ... */ (istat.level ^= 3) then
						/* or this is not a terminate ... */
		     call REREADY_TAPE ("0"b);	/* ask to have the tape rereadied. */
		else do;				/* turn on mount timer to make sure we don't loose this user. */
		     device_off = rcse.device_off;	/* Get RCPD offset of this device. */
		     write_flag = rcse.flags.writing;	/* Pass on write flag. */
		     call rcp_mount_timer_$set (device_off, write_flag, ecode);
		end;
		arg_ecode = ecode;
		return;
	     end;
	     else do;				/* No special and not preloaded, just wait for it. */
		arg_ecode = 0;
		return;
	     end;
	if rcse.model = 400				/* Special case 400 type drives. */
	     then
	     goto CHECK_READY;

/* Get the special status bits we need. */
	special_status_bits = substr (special_status_word, 30, 7);

	if special_status_bits = "0101000"b then do;	/* If special is from UNLOAD wait for another. */
	     arg_ecode = 0;
	     return;
	end;

	if substr (special_status_bits, 1, 1)		/* REWIND COMPLETE is ON. */
	     then
	     goto CHECK_READY;

	if ^substr (special_status_bits, 3, 1)		/* READY must be ON. */
	then do;					/* We got special but tape still not ready. */
	     call REREADY_TAPE ("0"b);
	     arg_ecode = ecode;
	     return;
	end;

CHECK_READY:
	if rcse.flags.preloaded then			/* This is a preloaded volume, let the operator know. */
	     call admin_gate_$syserr (0, "RCP: Using Reel ^a on ^a for ^a", rcse.volume_name, rcse.device_name,
		rcse.group_id);
	istat.completion.st = "0"b;			/* TAPE READY - check its current state. */
	if rcse.flags.fips then
	     addr (wspace.idcw) -> idcw.command = request_status_command;
	else addr (wspace.idcw) -> idcw.command = set_write_permit_command;
	call ioi_$connect (ioi_index, 0, ecode);
	wspace.state = wspace.state + 1;		/* Wait for command to terminate. */
	device_off = rcse.device_off;			/* Turn OFF mount timer. */
	call rcp_mount_timer_$reset (device_off, scode);
	if ecode = 0 then
	     ecode = scode;
	arg_ecode = ecode;
	return;


/*	Check the status from the (request status, reset status or set write
   *      permit) operation.  We must check that the write ring is correct.
   *	If everything is OK we will indicate that the attachment has been
   *	completed.
*/
TAPE_STATE (3):					/* SET WRITE PERMIT TERMINATION. */
	if ^istat.completion.st			/* Is there any status. */
	then do;					/* No, ignore. */
	     arg_ecode = 0;
	     return;
	end;

	statp = addr (istat.iom_stat);		/* Get pointer to IOM status. */

	if (istat.completion.er) | /* Is there an error? */ (istat.level ^= 3)
						/* Or is this not a terminate? */
	then do;					/* Yes, try to ready tape again. */
	     if (status.major = "0101"b) /* Command Reject */ & ((status.sub & "71"b3) = "01"b3)
						/* Invalid OP Code */
		& (addr (wspace.idcw) -> idcw.command = set_write_permit_command) then do;
						/* We probably tries to set permit when there was no ring */
		addr (wspace.idcw) -> idcw.command = reset_status_command;
		call ioi_$connect (ioi_index, 0, ecode);
		arg_ecode = ecode;
		return;
	     end;
	     call REREADY_TAPE ("0"b);
	     arg_ecode = ecode;
	     return;
	end;

	if (status.sub & "000010"b) ^= "000010"b then do; /* Tape not at BOT. */
	     call REREADY_TAPE ("0"b);
	     arg_ecode = ecode;
	     return;
	end;

	if rcse.flags.writing = ((status.sub & "001001"b) = "000001"b) then do;
						/* Write ring is not correct. */
	     call REREADY_TAPE ("1"b);
	     arg_ecode = ecode;
	     return;
	end;


/* Initialize the internal procedure states for label checking. */

	wspace.state = 4;
	wspace.read_label_state = 1;
	wspace.get_authentication_state = 1;
	wspace.tape_state_4_state = 1;

/* Initialize the flags used by the label checking procedures. */

	wspace.den_set = "0"b;
	wspace.nrzi_den_set = "0"b;
	wspace.record_read = "0"b;
	wspace.unreadable_tape = "0"b;
	wspace.bad_mode = "0"b;
	wspace.wait = "0"b;
	wspace.label_match = "0"b;
	wspace.label_name = "";
	wspace.blank_tape = "0"b;
	wspace.manual_halt = "0"b;
	wspace.ansi_non_blank_access = "0"b;

/* Initialize the authentication bits in the rcse. */

	rcse.flags.have_auth = "0"b;
	rcse.flags.need_auth = "0"b;
	rcse.flags.auth_set = "0"b;

/* Now we will enter the label checking state.  It has a number of internal states
   which are remembered by the state variables in our workspace.
*/

TAPE_STATE (4):
	write_flag = rcse.flags.writing;
	goto STATE (wspace.tape_state_4_state);		/* get to the proper internal state. */

STATE (1):
	wspace.tape_state_4_state = 1;
	call read_label ();

	if wspace.wait then
	     goto RETURN;				/* let our caller wait for an event. */

	users_requested_volume_name = rcse.volume_name;

	call validate_tape_label (addr (wspace.label_buffer), rcse.volume_name, wspace.label_match, wspace.label_name,
	     wspace.label_type);

	rcse.flags.label_type = wspace.label_type;	/* copy label type */
	if (wspace.label_match & ^rcse.must_auto_register) | rcpd.modes.authentication_level = No_authentication
	     | rcse.group_id = "Initializer.SysDaemon.z" then do;
						/* We are done */
	     wspace.rewind_state = 1;
STATE (2):
	     wspace.tape_state_4_state = 2;
	     call rewind ();

	     if wspace.wait then
		goto RETURN;

	     call ioi_$set_status (ioi_index, 0, 0, ecode);
	     if ecode = 0 then do;
		rcse.state = 4;
		wspace.state = 0;

		if ^write_flag & wspace.label_name ^= "" then
		     rcse.volume_name = wspace.label_name;
		rcse.flags.volume_density_index = DENSITY_INDEX (wspace.i);
						/* return density */
		rcse.flags.label_type = wspace.label_type;
						/* and label type */
	     end;
	end;

	else do;					/* label did not match. */
STATE (3):
	     wspace.tape_state_4_state = 3;
	     call get_authentication ();

	     if wspace.wait then
		goto RETURN;

	     if rcse.flags.have_auth then do;		/* We are done */
		wspace.rewind_state = 1;
STATE (4):
		wspace.tape_state_4_state = 4;
		call rewind ();

		if wspace.wait then
		     goto RETURN;

		call ioi_$set_status (ioi_index, 0, 0, ecode);
		if ecode = 0 then do;
		     rcse.state = 4;
		     wspace.state = 0;
		     if ^write_flag & wspace.label_name ^= "" then
			rcse.volume_name = wspace.label_name;
		     rcse.flags.volume_density_index = DENSITY_INDEX (wspace.i);
						/* return density */
		     rcse.flags.label_type = wspace.label_type;
						/* and label type */
		end;
		if rcse.flags.must_auto_register	/* Must ask RCPRM to register this volume for this user. */
		     then
		     call rcp_auto_register_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), (users_requested_volume_name),
			(rcse.group_id), ecode);
	     end;

	     else do;				/* authentication was denied. */
		call admin_gate_$syserr (0, "RCP: Authentication code for ^a does not match.", rcse.device_name);
		wspace.retry_count = 0;		/* start over with a new tape. */
		call REREADY_TAPE ("1"b);		/* Remount the (hopefully) correct tape. */
	     end;
	end;

RETURN:
	arg_ecode = ecode;
	return;

/**/
REREADY_TAPE:
     procedure (remount_flag);

/*	This procedure is called to tell the operator to ready the tape again.
   *	We will have to wspace.wait for the special again.
*/
dcl  remount_flag bit (1);				/* ON => remount,  OFF => reready. */

	if wspace.retry_count = max_num_retries		/* Have we retried too many times. */
	then do;					/* Yes, abort attachment. */
	     ecode = error_table_$device_attention;
	     return;
	end;
	wspace.retry_count = wspace.retry_count + 1;

/* Turn ON mount timer. */
	device_off = rcse.device_off;			/* Get RCPD offset of this device. */
	write_flag = rcse.flags.writing;		/* Pass on write flag. */
	call rcp_mount_timer_$set (device_off, write_flag, ecode);
	if ecode ^= 0 then
	     return;

	if remount_flag				/* Remount or reready? */
	then do;					/* Remount. */
	     istat.completion.st = "0"b;		/* Unload reel for operator. */
	     addr (wspace.idcw) -> idcw.command = rewind_unload_command;
	     call ioi_$connect (ioi_index, 0, ecode);
	     call admin_gate_$syserr (3, "RCP: Remount Reel ^[scratch^s^;^a^] ^a ring on ^a", (rcse.volume_name = ""),
		rcse.volume_name, wspace.ring_comment, rcse.device_name);
	end;
	else if rcse.flags.preloaded then
	     call admin_gate_$syserr (3, "RCP: Reready Reel ^a on ^a for ^a", rcse.volume_name, rcse.device_name,
		rcse.group_id);
	else call admin_gate_$syserr (3, "RCP: Reready ^a", rcse.device_name);

	wspace.state = wspace.mount_state;		/* Wait for special(s) again. */

     end REREADY_TAPE;

/**/
read_label:
     proc;

	goto STATE (wspace.read_label_state);

STATE (1):
	wspace.read_label_state = 1;
	wspace.record_read = "0"b;
	wspace.unreadable_tape = "0"b;
	wspace.i = 1;				/* Start at NRZI density of 800 bpi. */
	wspace.nrzi_den_set = "0"b;			/* Haven't sucessfully set one yet. */
try_next_density:					/* There is only one transfer to this label. */
	wspace.set_density_state = 1;
STATE (2):
	wspace.read_label_state = 2;
	call set_density ();

	if wspace.wait then
	     return;

	if wspace.den_set then do;

	     wspace.nrzi_den_set = "1"b;

	     wspace.read_record_state = 1;
STATE (3):
	     wspace.read_label_state = 3;
	     call read_record ();

	     if wspace.wait then
		return;

	     if wspace.bad_mode then do;		/* May be PE mode, 1600 bpi. */
try_pe:
		wspace.rewind_state = 1;
STATE (4):
		wspace.read_label_state = 4;
		call rewind ();			/* Back to load point to set new density. */

		if wspace.wait then
		     return;

		wspace.set_density_state = 1;
STATE (5):
		wspace.read_label_state = 5;
		wspace.i = 4;			/* Code for 1600 bpi. */
		call set_density ();

		if wspace.wait then
		     return;

		if wspace.den_set then do;
		     wspace.read_record_state = 1;
STATE (6):
		     wspace.read_label_state = 6;
		     call read_record ();

		     if wspace.wait then
			return;

		     if wspace.bad_mode then do;	/* Must be GCR mode, 6250  bpi. */
try_gcr:
			wspace.rewind_state = 1;
STATE (8):
			wspace.read_label_state = 8;
			call rewind ();		/* Back to load point to set new density. */

			if wspace.wait then
			     return;

			wspace.set_density_state = 1;
STATE (9):
			wspace.read_label_state = 9;
			wspace.i = 5;		/* Code for 6250 bpi. */
			call set_density ();

			if wspace.wait then
			     return;

			if wspace.den_set then do;
			     wspace.read_record_state = 1;
STATE (10):
			     wspace.read_label_state = 10;
			     call read_record ();

			     if wspace.wait then
				return;

			     if wspace.bad_mode then do;
						/* This should never happen. */
				wspace.unreadable_tape = "1"b;
						/* Tried NRZI, PE, and GCR modes and still got bad mode. */
			     end;

			     else if wspace.blank_tape | wspace.record_read then do;
						/* Success. */
				wspace.unreadable_tape = "0"b;
			     end;

			     else if wspace.manual_halt then do;
						/* Drive in standby. */
				wspace.unreadable_tape = "1"b;
			     end;

			     else do;		/* Tape is unreadable at the only GCR density. */
				wspace.unreadable_tape = "1"b;
			     end;
			end;

			else do;			/* Could'nt try the only available GCR density. */
			     wspace.unreadable_tape = "1"b;
			end;
		     end;				/* Must be GCR mode, 6250 bpi. */

		     else if wspace.blank_tape | wspace.record_read then do;
						/* Success. */
			wspace.unreadable_tape = "0"b;
		     end;

		     else if wspace.manual_halt then do;/* Drive in standby. */
			wspace.unreadable_tape = "1"b;
		     end;

		     else do;			/* Tape is unreadable at the only PE density. */
			wspace.unreadable_tape = "1"b;
		     end;
		end;

		else do;				/* Could'nt try the only available PE density. */
		     goto try_gcr;			/* Maybe it is GCR, 6250 bpi. */
		end;
	     end;					/* May be PE mode, 1600 bpi. */

	     else if wspace.blank_tape | wspace.record_read then do;
						/* Success. */
		wspace.unreadable_tape = "0"b;
	     end;

	     else if wspace.manual_halt then do;	/* Drive in standby. */
		wspace.unreadable_tape = "1"b;
	     end;

	     else do;				/* Unreadable at this NRZI density. */
wrong_density:					/* There is only one transfer to this label. */
		wspace.unreadable_tape = "1"b;

		wspace.i = wspace.i + 1;		/* Try all 3 NRZI densities */
		if wspace.i <= 3			/* before giving up. */
		then do;
		     wspace.rewind_state = 1;
STATE (7):
		     wspace.read_label_state = 7;
		     call rewind ();		/* Back to load point to set new density. */

		     if wspace.wait then
			return;

		     goto try_next_density;		/* This is the only transfer to this label. */
		end;

		else do;				/* Maybe no NRZI density could be set. */
		     if ^wspace.nrzi_den_set then
			goto try_pe;
		end;
	     end;
	end;

	else goto wrong_density;			/* Could'nt use this NRZI density. */
						/* This is the only transfer to this label. */

     end read_label;

/**/
set_density:
     proc;

/* This procedure uses wspace.i to pick out the density that it is supposed to set. */

	goto STATE (wspace.set_density_state);

STATE (1):
	wspace.set_density_state = 1;
	addr (wspace.idcw) -> idcw.command = density (wspace.i);
	istat.completion.st = "0"b;
	call ioi_$connect (ioi_index, 0, ecode);	/* Initiate the set density command. */

STATE (2):
	wspace.set_density_state = 2;
	if istat.completion.st & istat.level = 3 then do; /* We have some status back */
	     wspace.wait = "0"b;			/* Don't need to wait any more. */

	     if istat.completion.er then
		wspace.den_set = "0"b;		/* Some error setting the density. */
	     else wspace.den_set = "1"b;		/* Everything is OK. */
	end;

	else wspace.wait = "1"b;			/* Must let our caller wait for an event. */

     end set_density;

/**/
read_record:
     proc;

/*
   This procedure tries to read the first good record on the tape.  The first
   record is assumed to be the tape label.
   Notice that even though the Multics Standard Tape (MST) format normally
   will write up to 64 records to get a good copy for the label record it
   always backspaces and rewrites until it gets a good label as the first
   record on the tape.
*/

	goto STATE (wspace.read_record_state);

STATE (1):
	wspace.read_record_state = 1;
	wspace.j = 1;

	wspace.record_read = "0"b;
	wspace.bad_mode = "0"b;
	wspace.blank_tape = "0"b;
	wspace.manual_halt = "0"b;
	istat.completion.st = "0"b;
	call ioi_$connect (ioi_index, 1, ecode);	/* Initiate the read record binary command. */

STATE (2):
	wspace.read_record_state = 2;
	if istat.completion.st & istat.level = 3 then do;
	     wspace.wait = "0"b;			/* Don't need to wait anymore. */

	     if istat.completion.er then do;		/* Some error occured while reading. */
		statp = addr (istat.iom_stat);

		if status.major = "1010"b /* MPC Device Attention */ & status.sub = "001000"b
						/* Incompatible Mode */
		then do;
		     wspace.bad_mode = "1"b;
		end;

		else if status.major = "0011"b /* Device Data Alert */ & status.sub = "000010"b
						/* Blank Tape on Read */
		then do;
		     wspace.blank_tape = "1"b;
		end;

		else if status.major = "0010"b /* Device attention */ & (status.sub & "100110"b) = "000100"b
						/* Device in standby */
		then do;
		     wspace.manual_halt = "1"b;
		end;

		else ;				/* Some other error, give up. */
	     end;

	     else do;				/* Good read. */
		wspace.record_read = "1"b;
	     end;
	end;

	else wspace.wait = "1"b;			/* Let our caller wait for an event. */

     end read_record;

/**/
rewind:
     proc;

	goto STATE (wspace.rewind_state);

STATE (1):
	wspace.rewind_state = 1;
	istat.completion.st = "0"b;
	call ioi_$connect (ioi_index, 3, ecode);	/* Initiate the rewind command */

STATE (2):
	wspace.rewind_state = 2;
	if istat.completion.st & istat.level = 3 then do; /* We got the status from start of rewind. */
	     if istat.completion.er then do;
		call admin_gate_$syserr (3, "RCP: Manually rewind and reready ^a.", rcse.device_name);
		call rcp_mount_timer_$set ((rcse.device_off), (rcse.flags.writing), ecode);
	     end;

STATE (3):
	     wspace.rewind_state = 3;
	     call ioi_$get_special_status (ioi_index, special_flag, special_status_word, ecode);

	     if ecode ^= 0 | ^special_flag then
		wspace.wait = "1"b;			/* wait some more for the special. */
	     else do;				/* tape is finished rewinding. */
		call rcp_mount_timer_$reset ((rcse.device_off), ecode);
		wspace.wait = "0"b;
	     end;
	end;
	else wspace.wait = "1"b;			/* Let our caller wait for an event. */

     end rewind;

/**/
get_authentication:
     proc;

dcl  authentication_label_name char (32);

	goto STATE (wspace.get_authentication_state);

STATE (1):
	wspace.get_authentication_state = 1;
	rcse.flags.need_auth = "1"b;
	rcse.flags.have_auth = "0"b;
	rcse.flags.auth_set = "0"b;

/* Get rid of non-printable chars by replacing with ".", 208+208 = 416 because of implementation restriction */

	authentication_label_name =
	     translate (wspace.label_name, (208)"." || (208)".",
	     substr (collate9 (), 1, 32) || substr (collate9 (), 128));
	call admin_gate_$syserr (3,
	     "RCP: Authenticate ^a.  It has ^a label ^[(Manual Halt)^2s^;^a^[ (with non-blank accessibility code)^]^].^[
RCP: WARNING!!  IF YOU AUTHENTICATE THIS REQUEST ^a WILL OWN VOLUME ^a!^]", rcse.device_name,
	     Tape_volume_types (wspace.label_type), wspace.manual_halt, authentication_label_name,
	     wspace.ansi_non_blank_access, rcse.flags.must_auto_register, rcse.group_id, rcse.volume_name);

	device_off = rcse.device_off;
	write_flag = rcse.flags.writing;
	call rcp_mount_timer_$set (device_off, write_flag, ecode);

STATE (2):
	wspace.get_authentication_state = 2;
	if rcse.flags.auth_set then do;		/* The operator has responded. */
	     wspace.wait = "0"b;
	     device_off = rcse.device_off;
	     call rcp_mount_timer_$reset (device_off, ecode);
	end;

	else wspace.wait = "1"b;			/* Let our caller wait for an event. */

     end get_authentication;

/**/
validate_tape_label:
     proc (label_ptr, user_label, label_match, label_name, label_type);

dcl  (
     label_ptr ptr,					/* pointer to label record from tape. */
     user_label char (*) aligned,			/* user specified volume id. */
     label_match bit (1),				/* true if labels match, false otherwise. */
     label_name char (32),				/* volume id from tape label record. */
     label_type fixed bin
     ) parameter;					/* type of label. */

dcl  user_name char (32),				/* fixed length user label. */
     canon_user_name char (32),			/* canonicalized user name. */
     canon_label_name char (32),			/* canonicalized label name. */
     label_auth char (3),				/* authentication code from label */
     computed_auth_code char (3) aligned;		/* computer from user name */


/* TAPE LABEL FORMATS */

dcl  1 mult based (label_ptr) unaligned,		/* Multics standard version 1 label structure */
       2 lab_id bit (36),				/* this will be 670314355245 in octal */
       2 pad (15) bit (36),				/* we ignore this */
       2 vol_id char (32);				/* this is in ascii */

dcl  1 gcos based (label_ptr) unaligned,
       2 lab_id bit (12 * 6),				/* this will be "GE  600 BTL " in bcd */
       2 installation_id bit (6 * 6),			/* we ignore this */
       2 pad_vol_id bit (6),				/* pad first bit of vol_id as it is not used	*/
       2 vol_id bit (6 * 6),				/* this is in bcd */
       2 (file_ser, reel_seq, creation_date, retention_days, file_name) bit (6 * 6),
						/* we don't use these */
       2 label_auth bit (3 * 6);			/* authentication code */

dcl  1 ibm based (label_ptr) unaligned,
       2 lab_id bit (4 * 8),				/* this will be "VOL1" in ebcdic */
       2 vol_id bit (6 * 8),				/* this is in ebcdic */
       2 reserved bit (31 * 8),			/* we don't use these */
       2 label_auth bit (10 * 8);			/* authentication code */

dcl  1 ansi based (label_ptr) unaligned,
       2 lab_id bit (4 * 8),				/* this will be "VOL1" in ascii (8 bit) */
       2 vol_id bit (6 * 8),				/* this is in 8 bit ascii */
       2 accessibility bit (1 * 8),			/* this is in 8 bit ascii, blank--OK, non-blank--authenticate */
       2 reserved bit (26 * 8),			/* we don't use these */
       2 label_auth bit (14 * 8);			/* authentication code */




/*
   Now see if we can find a volume id on this tape label.
*/

	label_name = "";
	label_auth = "";
	label_type = Volume_unknown_format;
	user_name = user_label;

	if wspace.blank_tape then
	     label_type = Volume_blank;

	else if wspace.unreadable_tape | wspace.manual_halt then
	     label_type = Volume_unreadable;

	else if mult.lab_id = header_c1 then do;	/* Version 1 Multics standard label? */
	     label_type = Volume_multics_tape;
	     label_name = mult.vol_id;		/* get the volume id. */
	     label_auth = "***";
	end;
	else if mult.lab_id = label_c1		/* Version 2 Multics standard label? */
	     then
	     if (label_ptr -> mst_label.head.c1 = header_c1 & label_ptr -> mst_label.head.label)
						/* if all this is true yes */
	     then do;
		label_type = Volume_multics_tape;
		label_name = label_ptr -> mst_label.tape_reel_id;
						/* get the volume id. */
		label_auth = "***";
	     end;
	     else ;

	else if gcos.lab_id = "272520200600002022634320"b3 then do;
						/* "GE  600 BTL " in bcd */
	     label_type = Volume_gcos_tape;
	     call bcd_to_ascii_ (string (gcos.vol_id), label_name);
	     call bcd_to_ascii_ (string (gcos.label_auth), label_auth);
	end;

	else if ibm.lab_id = "E5D6D3F1"b4 then do;	/* "VOL1" in 8 bit ebcdic */
	     label_type = Volume_ibm_tape;
	     call ebcdic8_to_ascii_ (string (ibm.vol_id), label_name);
	     call ebcdic8_to_ascii_ (string (ibm.label_auth), label_auth);
	end;

	else if ansi.lab_id = "564F4C31"b4 then do;	/* "VOL1"b in 8 bit ascii */
	     label_type = Volume_ansi_tape;
	     call unpack (ansi.vol_id, label_name);
	     call unpack (ansi.label_auth, label_auth);

	     if ansi.accessibility ^= "20"b4 then
		wspace.ansi_non_blank_access = "1"b;
	end;

	else label_type = Volume_unknown_format;	/* Doesn't look like a recognizable label */


/* Now see if the tape label we found matches the user specified label. */

	if label_name = "" then do;
	     label_match = ""b;
	     return;
	end;

	label_match = "1"b;				/* assume so unless we turn it off */

	if rcpd.modes.authentication_level = Manual_authentication then do;
	     label_match = ""b;
	     return;
	end;

/* nominal authentication mechanism is here */

	if wspace.ansi_non_blank_access then do;	/* Always authenticate this. */
	     label_match = "0"b;
	     return;
	end;

/* canonicalize the tape label just read */

	call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), label_name, canon_label_name, label_type, ecode);
	if ecode ^= 0 then
	     label_match = ""b;
	else do;					/* canonicalize the user name  */
	     call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), user_name, canon_user_name, label_type, ecode)
		;
	     if ecode ^= 0 then
		label_match = ""b;
	     else if canon_user_name ^= canon_label_name then
		label_match = ""b;
	end;

	if rcpd.modes.authentication_level = Nominal_authentication
	     | rcpd.modes.authentication_level = No_authentication | rcse.group_id = "Initializer.SysDaemon.z" then do;
	     label_name = canon_label_name;
	     return;
	end;

/* full, secure automatic authentication mechanism is here */

	if label_type = Volume_multics_tape then
	     return;				/* no further checks necessary */

	computed_auth_code = authenticate_ (user_name);
	if computed_auth_code ^= label_auth then
	     label_match = ""b;

	return;

     end validate_tape_label;

/**/
unpack:
     proc (input, output);

dcl  input bit (*);
dcl  output char (*);

dcl  char_code fixed bin (17);
dcl  char_limit fixed bin;
dcl  input_chars (1:divide (length (input), 8, 24)) bit (8) based (addr (input));
dcl  char_index fixed bin;

	output = "";
	char_limit = min (hbound (input_chars, 1), length (output));

	do char_index = lbound (input_chars, 1) to char_limit by 1;
	     char_code = fixed (input_chars (char_index), 17);
	     substr (output, char_index, 1) = substr (collate9 (), char_code + 1, 1);
	end;

     end unpack;

Print_Mount_Message:
     proc ();


dcl  rcp_pointers_$data entry () returns (ptr);
dcl  rcprm_find_resource_$status entry (ptr, char (*), fixed bin (35));


	if ^rcp_pointers_$data () -> rcpd.modes.resource_mgmt_enabled then
	     call admin_gate_$syserr (3, "RCP: Mount Reel ^[scratch^s^;^a^] ^a ring on ^a for ^a",
		(rcse.volume_name = ""), rcse.volume_name, wspace.ring_comment, rcse.device_name, rcse.group_id);
	else do;
	     Resource_count = 1;
	     begin;

dcl  garbage (size (resource_descriptions)) bit (36);

		string (garbage) = ""b;
		resource_desc_ptr = addr (garbage);

		resource_descriptions.version_no = resource_desc_version_1;
		resource_descriptions.n_items = 1;
		resource_descriptions.item (1).type = VOLUME_TYPE (TAPE_VOL_VTYPEX);
		resource_descriptions.item (1).name = rcse.volume_name;
		resource_descriptions.item (1).given.name = "1"b;

		call rcprm_find_resource_$status (resource_desc_ptr, (rcs.acs_directory), ecode);

		if ecode = error_table_$action_not_performed then
		     ecode = resource_descriptions.item (1).status_code;

		if ecode ^= 0			/* We won't try to print location if we can't get it. */
		then do;
		     resource_descriptions.item (1).location = "";
		     ecode = 0;
		end;

		call admin_gate_$syserr (3, "RCP: Mount ^[(from ""^a"") ^;^s^]Reel ^a ^a ring on ^a for ^a",
		     (resource_descriptions.item (1).location ^= ""), resource_descriptions.item (1).location,
		     rcse.volume_name, wspace.ring_comment, rcse.device_name, rcse.group_id);
	     end;
	end;


	return;


     end Print_Mount_Message;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Mount Reel REELID with(out) ring on DRIVE for PERSON.PROJ.T.

   S:	$beep

   T:	$run

   M:	A user process has requested the mounting of
   tape reel REELID on drive DRIVE.

   A:	Locate the requested reel.
   Check to make sure that the user PERSON.PROJ is allowed to use the reel.
   Insert or remove a write ring as specified.
   Mount the reel on the specified drive.

   If the reel cannot be mounted, either because it
   cannot be located,
   access is incorrect,
   or the drive is down,
   use the "x deny" function to reject the mount request.


   Message:
   RCP: Remount Reel REELID with(out) ring on DRIVE.

   S:	$beep

   T:	$run

   M:	The system found a write
   ring when one was not required,
   or did not find one when one was needed.
   Or the authentication code did not match.
   The tape is unloaded.

   A:	Correct the write ring status or mount the correct tape and reready the tape.


   Message:
   RCP: Reready DRIVE.

   S:	$beep

   T:	$run

   M:	DRIVE has dropped out of ready status.

   A:	Reready it.


   Message:
   RCP: Authentication code for DRIVE does not match.

   S:	$info

   T:     $run

   M:	The authentication code typed for the
   volume on DRIVE does no match the user
   specified volume name.

   A:	$ignore


   Message:
   RCP: Authenticate DRIVE. It has LABEL_TYPE label LABEL.

   S:	$beep

   T:	$run

   M:	The system cannot determine that the volume on DRIVE is the one
   requested.  The operator must authenticate the volume.  The label read from
   the tape on DEVICE was of type LABEL_TYPE and was LABEL.  If LABEL is
   "(Manual Halt)" this indicates that the tape drive was found in standby
   while trying to read/verify the label.  If LABEL_TYPE is ANSI and LABEL is
   "<label> (with non-blank accessibility code)" this indicates that the label
   is an ANSI label with a non-blank character in the accessibility field, the
   operator must consult the site standards for authenticating such tapes
   before doing the authentication.  Any non-printable characters in the label
   are represented by ".".

   A:	If the volume is correct then
   use the "x auth" function to input the DRIVE number and
   the authentication code on the tape volume, or "***" if there is no
   authentication code.  If authentication was requested due to the drive being in standby,
   the tape should be rewound manually and rereadied manually and the above procedure
   for authentication followed.


   Message:
   RCP: Authenticate DRIVE. It has LABEL_TYPE label LABEL and is UNREGISTERED.

   S:	$beep

   T:	$run

   M:	The tape volume requested is not a registered tape volume. In addittion, the system may
   not have been able to determine that the volume loaded is in fact the one requested. The
   label read from the tape on DEVICE was of type LABEL_TYPE and was LABEL. If LABEL is
   "(Manual Halt)" this indicates that the tape drive was found in standby while trying to
   read/verify the label. Any non-printable characters in the label are represented by ".".

   A:	If the volume is correct and is to be registered to the user requesting this attachment
   use the "x auth" function to input the DRIVE number and the authentication code on the
   tape volume, or "***" if there is no authentication code. If authentication was requested
   due to the drive being in standby, the tape should be rewound manually and rereadied
   manually and the above procedure for authentication followed.


   Message:
   RCP: Using Reel REELID on DRIVE for PERSON.PROJ.T.

   S:	$info

   T:	$run

   M:	Using a preloaded volume.

   A:	$ignore


   Message:
   RCP: Reready Reel REELID on DRIVE for PERSON.PROJ.T.

   S:	$beep

   T:	$run

   M:	A preloaded volume was not ready.

   A:	Make the volume ready.


   Message:
   RCP: WARNING!!  IF YOU AUTHENTICATE THIS REQUEST <USER> WILL OWN VOLUME <VOLUME>!

   S:	$beep

   T:	$run

   M:	This is a warning to the operator.  IHe should be very careful to check the
   physical label of the volume before authenticating this request.  As the message states,
   if the request is autheticated, <VOLUME> will be registered and acquired to <USER>.

   A:	Check the physical label of the tape volume.  If it is the property of
   <USER>, authenticate the request.  If it is not the property of <USER> deny the
   request by typing "x auth no".


   END MESSAGE DOCUMENTATION */

     end rcp_tape_;




		    rcp_tape_survey_.pl1            11/11/89  1110.3rew 11/11/89  0805.9       75303



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(85-12-17,CLJones), install(86-03-21,MR12.0-1033):
     FIPS support by
     checking for device zero, add tri-density for STC drives, and survey to
     the DRIVE instead of controller for FIPS.
  2) change(86-04-11,Farley), approve(86-04-11,MCR6979),
     audit(86-04-11,Fawcett), install(86-04-14,MR12.0-1039):
     Post Bug Fix (PBF) to change FIPS attachment to attach the psuedo IOI
     controller entry, instead of the FIPS device. This was needed to correct a
     problem with adding a device back on after it had been deleted during
     startup.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
rcp_tape_survey_:
     procedure (Device, Drive, Fips, Operational, Qualifiers, Code);

/*	Perform survey of all tape devices.
   *	Created on 11/13/74 by Bill Silver.
   *	Modified on 1/20/77 by Noel I. Morris for multiple tape controllers.
   *	Modified 31 July 1981 to avoid looping forever on a dead tape controller, W. Olin Sibert
   *	Modified September 1981 by J. Bongiovanni to set mask to open-level
   *	Modified 9/81 to identify itself in all syserr messages, M.R. Jordan
   *	Modified June 1982 by C. Hornig to run in ring 1.
   *	Modified 4/10/84 by GA Texada to support FIPS.
   *	Modified 8/01/84 by Paul Farley to add check for zero
   *	survey_data.handler data, so device 0 checking would work properly.
   *	Modified 1/85 by Paul Farley for tri-density STC tape drives.
   *
   *	This is a system initialization procedure.  It is called by rcp_init.
   *	It will use IOI to perform a survey_devices command to the tape controller.
*/

/*		ARGUMENT  DATA		*/

dcl  Device char (*) parameter;
dcl  Drive fixed bin parameter;
dcl  Fips bit (1) aligned parameter;
dcl  Operational bit (1) aligned parameter;
dcl  Qualifiers (4) fixed bin (35) parameter;
dcl  Code fixed bin (35) parameter;


/*		AUTOMATIC  DATA		*/

dcl  ecode fixed bin (35);				/* error_table_ code. */
dcl  ioi_index fixed bin;				/* IOI device index. */
dcl  i fixed bin;
dcl  ws_ptr ptr;					/* Pointer to IOI workspace segment. */
dcl  1 wait_list aligned,				/* for ipc_$block */
       2 count fixed bin init (1),
       2 pad fixed bin,
       2 ev_chn (1) fixed bin (71);
dcl  1 ev_msg aligned like event_wait_info;

/*		BASED  DATA		*/

dcl  1 ws aligned based (ws_ptr),			/* IOI workspace. */
       2 idcw bit (36),				/* Survey_devices tape command. */
       2 dcw bit (36),				/* DCW for survey_devices command. */
       2 survey_data,
         3 handler (16) unaligned,
	 4 pad1 bit (1),
	 4 reserved bit (1),
	 4 operational bit (1),
	 4 ready bit (1),
	 4 number uns fixed bin (5),
	 4 pad2 bit (1),
	 4 speed uns fixed bin (3),
	 4 nine_track bit (1),
	 4 density uns fixed bin (4);

dcl  (addr, binary, bit, rel, size, unspec) builtin;

/* CONSTANTS */

dcl  density_table (0:15) bit (5) static options (constant) /* Used to set density characteristic. */
	init ("00010"b,				/* 1600 */
	"11100"b,					/* 200 , 556 , 800 */
	"00000"b,					/* Invalid */
	"00000"b,					/* Invalid */
	"11110"b,					/* 200, 556, 800, 1600 */
	"01110"b,					/* 556, 800, 1600 */
	"00000"b,					/* Invalid */
	"00111"b,					/* 800, 1600, 6250 */
	"00110"b,					/* 800, 1600 */
	"01100"b,					/* 556, 800 */
	"00000"b,					/* Invalid */
	"00011"b,					/* 1600, 6250 */
	"00000"b,					/* Invalid */
	"00000"b,					/* Invalid */
	"00000"b,					/* Invalid */
	"00000"b);				/* Invalid */

dcl  speed_table (0:7) bit (3) static options (constant)	/* Used to set speed characteristics. */
	init ("000"b,				/* Invalid */
	"100"b,					/* 75 ips */
	"010"b,					/* 125 ips */
	"000"b,					/* Invalid */
	"001"b,					/* 200 ips */
	"000"b,					/* Invalid */
	"000"b,					/* Invalid */
	"000"b);					/* Invalid */

/* EXTERNAL */

dcl  admin_gate_$ioi_attach entry (fixed bin, char (*), fixed bin (71), bit (1) aligned, fixed bin (35));
dcl  admin_gate_$ioi_detach entry (fixed bin, fixed bin (35));
dcl  admin_gate_$syserr 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  ioi_$connect entry (fixed bin, fixed bin, fixed bin (35));
dcl  ioi_$timeout entry (fixed bin, fixed bin (71), fixed bin (35));
dcl  ioi_$workspace entry (fixed bin, ptr, fixed bin, fixed bin (35));
%page;
	Qualifiers (*) = 0;
	Operational = "0"b;
	wait_list.ev_chn (1) = 0;
	ioi_index = 0;

	call ipc_$create_ev_chn (wait_list.ev_chn (1), Code);
	if Code ^= 0 then goto return_to_caller;

	if Fips
	then call admin_gate_$ioi_attach (ioi_index, Device, wait_list.ev_chn (1), "1"b, Code);
	else call admin_gate_$ioi_attach (ioi_index, Device || "_00", wait_list.ev_chn (1), "1"b, Code);
	if Code ^= 0 then goto return_to_caller;

	call ioi_$workspace (ioi_index, ws_ptr, size (ws), Code);
	if Code ^= 0 then goto return_to_caller;

	call ioi_$timeout (ioi_index, 1000000 /* 1 sec */, Code);
	if Code ^= 0 then goto return_to_caller;

	ws.idcw = "570000700000"b3;			/* Set up survey_devices tape command. */
	ws.dcw = ""b;				/* Set up DCW for survey_devices command. */
	dcwp = addr (ws.dcw);
	dcw.address = rel (addr (ws.survey_data));	/* Put survey_device info in workspace survey_data. */
	dcw.tally = bit (binary (8, 12));		/* Should return 8 words at most. */

	call ioi_$connect (ioi_index, binary (rel (addr (ws.idcw)), 18), Code);
	if Code ^= 0 then goto return_to_caller;

	call ipc_$block (addr (wait_list), addr (ev_msg), Code);
	if Code ^= 0 then goto return_to_caller;

	imp = addr (ev_msg.message);
	if imess.er
	then call admin_gate_$syserr (BEEP, "rcp_tape_survey_: Error surveying controller ^a: ^w", Device, imess.status)
		;

	else if imess.time_out
	then call admin_gate_$syserr (BEEP, "rcp_tape_survey_: Tape controller ^a did not respond within one second.",
		Device);

	do i = 1 to 16;
	     if unspec (ws.survey_data.handler (i)) ^= ""b then do;
		if ws.survey_data.handler (i).number = Drive then do;
		     if Operational then do;
			call admin_gate_$syserr (BEEP, "rcp_tape_survey_: Multiple device ^d's found on ^a.", Drive,
			     Device);
			Operational = "0"b;
			goto return_to_caller;
			end;

		     if ws.survey_data.handler (i).operational then do;
			Operational = "1"b;
			if ws.survey_data.handler (i).nine_track
			then Qualifiers (1) = 9;
			else Qualifiers (1) = 7;
			unspec (Qualifiers (2)) = density_table (ws.survey_data.handler (i).density);
			unspec (Qualifiers (3)) = speed_table (ws.survey_data.handler (i).speed);
			end;
		     end;
		end;
	end;

return_to_caller:
	if ioi_index ^= 0 then call admin_gate_$ioi_detach (ioi_index, ecode);
	if wait_list.ev_chn (1) ^= 0 then call ipc_$delete_ev_chn (wait_list.ev_chn (1), ecode);

	return;
%page;
%include event_wait_info;
%include ioi_stat;
%include iom_dcw;
%include iom_pcw;
%include syserr_constants;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   rcp_tape_survey_: Error surveying controller CONTROLLER: ERROR_STATUS

   S: $beep

   T: $init

   M: An error was received from IOI while attempting to survey the tape controller
   DEVICE.
   $err

   A: $inform
   $recover

   Message:
   rcp_tape_survey_: Tape controller CONTROLLER did not respond within one second.

   S: $beep

   T: $init

   M: The tape controller or IOM failed to respond to the survey-devices
   command by sending an interrupt within one second.

   A: Contact field engineering personnel.

   Message:
   rcp_tape_survey_: Multiple device NUMBER's found on CONTROLLER.

   S: $beep

   T: $init

   M: The survey information indicates that there are multiple devices
   with the same device number.

   A: Contact field engineering personnel.

   END MESSAGE DOCUMENTATION */

     end rcp_tape_survey_;




		    rcp_unassign_.pl1               11/11/89  1110.3r   11/11/89  0805.9       64458



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


rcp_unassign_: procedure;

/*	This program implements the RCP unassignment entry points.
   *	Created on 12/05/74 by Bill Silver.
   *	Modified 6/79 by Michael R. Jordan for MR7.0R.
   *      Modified early 1985 by Maria Pozzo for B2 access operations.
   *
   *	This program has the following entry points:
   *	     1.	unassign  -	Unassign a resource given an RCP ID.
   *	     2.	unassign_device  -	Unassign a device given its name.
*/

/*		ARGUMENT  DATA		*/

	dcl     arg_comment		 char (*);	/* (I) Caller's comment. */
	dcl     arg_device_name	 char (*);	/* (I) name of device to be unassigned. */
	dcl     arg_disposition	 bit (*);		/* (I) Reservation disposition - not used. */
	dcl     arg_ecode		 fixed bin (35);	/* (O) error_table_ code. */
	dcl     arg_rcp_id		 bit (36) aligned;	/* (I) ID used to identify RCS entry. */


/*		AUTOMATIC  DATA		*/

	dcl     device_offset	 bit (18) aligned;	/* Needed by rcp_control_. */
	dcl     process_id		 bit (36) aligned;	/* Process id of process amking request of rcp_control_. */
	dcl     rcp_id		 bit (36) aligned;	/* Used to copy rcp_id argument. */
	dcl     rcse_off		 bit (18);	/* Offset of an RCS entry. */
	dcl     volume_offset	 bit (18) aligned;	/* Needed by rcp_control_. */

	dcl     comment		 char (64);	/* Used to copy comment. */
	dcl     device_name		 char (32);	/* Name of device to unassign. */
	dcl     operation		 bit (36) aligned;	/* Operation being requested of rcp_control_. */

	dcl     caller_level	 fixed bin;	/* Caller's validation level. */
	dcl     ecode		 fixed bin (35);	/* error_table_ code. */
	dcl     error_count		 fixed bin (17);	/* Error count for device attachments */

	dcl     arcse_ptr		 ptr;		/* Pointer to attachment RCS entry. */


/*		BASED  DATA		*/

	dcl     1 arcse		 based (arcse_ptr) like rcse aligned; /* Used to reference attachment RCS entry. */


/*		EXTERNAL ENTRIES CALLED	*/

	dcl     cleanup		 condition;	/* Used to set up cleanup handler. */

	dcl     (addr, ptr)		 builtin;

	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$resource_unassigned fixed bin (35) ext static;

	dcl     access_operations_$rcp_unassign bit (36) aligned ext static;

	dcl     cu_$level_get	 entry (fixed bin);
	dcl     cu_$level_set	 entry (fixed bin);
	dcl     get_ring_		 entry returns (fixed bin);
	dcl     rcp_comment_	 entry (ptr);
	dcl     rcp_detach_$detach	 entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));
	dcl     rcp_find_$device	 entry (char (*), bit (18));
	dcl     rcp_control_	 entry (bit (36) aligned, bit (18) aligned, bit (18) aligned, char (*),
				 fixed bin (17), bit (36) aligned, fixed bin (35));
	dcl     rcp_pointers_$com_seg	 entry returns (ptr);
	dcl     rcp_rcse_$free	 entry (ptr, fixed bin (35));
	dcl     rcp_validate_	 entry (bit (36) aligned, fixed bin, ptr, fixed bin (35));

%include rcp_com_seg;

unassign: entry (arg_rcp_id, arg_disposition, arg_comment, arg_ecode);

/*	This entry is called to unassign a resource.  The rcp_id is used
   *	to generate a pointer to the RCS entry that is associated with
   *	the assignment of this resource.  Currently only resources that are
   *	devices may be unassigned via this entry.  If the rcp_id is valid we will
   *	perform the unassignment regardless of the current state of the assignment.
*/

	call SETUP;

	call cu_$level_get (caller_level);		/* Get caller's validation level. */
	on cleanup begin;				/* Cleanup if any trouble. */
		call cu_$level_set (caller_level);	/* Reset validation level to caller level. */
	     end;
	call cu_$level_set (get_ring_ ());		/* Set validation level to RCP level. */

	rcp_id = arg_rcp_id;			/* Copy arguments. */
	comment = arg_comment;

	call rcp_validate_ (rcp_id, caller_level, rcse_ptr, ecode);
	if ecode ^= 0				/* Is rcp_id OK? */
	then goto UNASSIGN_RETURN;			/* No. */

	if rcse.kind ^= 2				/* Is this an assignment entry? */
	then do;					/* No. */
		ecode = error_table_$bad_arg;
		goto UNASSIGN_RETURN;
	     end;

	call UNASSIGN_DEVICE;			/* Now unassign this device. */

UNASSIGN_RETURN:
	arg_ecode = ecode;
	call cu_$level_set (caller_level);
	return;

unassign_device: entry (arg_device_name, arg_disposition, arg_comment, arg_ecode);

/*	This entry is called to unassign a device given its name.
   *	We will call rcp_find_ to see if a device with this name is
   *	assigned to this process.  If so we will unassign it.
*/

	call SETUP;

	call cu_$level_get (caller_level);
	on cleanup begin;
		call cu_$level_set (caller_level);
	     end;
	call cu_$level_set (get_ring_ ());

	device_name = arg_device_name;		/* Copy arguments. */
	comment = arg_comment;

	call rcp_find_$device (device_name, rcse_off);

	if rcse_off = "0"b				/* Did we find the device? */
	then ecode = error_table_$resource_unassigned;
	else do;					/* Yes, unassign it. */
		rcse_ptr = ptr (rcp_pointers_$com_seg (), rcse_off);
		call UNASSIGN_DEVICE;
	     end;

	arg_ecode = ecode;				/* Return results. */
	call cu_$level_set (caller_level);
	return;

SETUP: procedure;

	device_offset = ""b;
	process_id = ""b;
	volume_offset = ""b;
	device_name = "";
	error_count = 0;

     end SETUP;

UNASSIGN_DEVICE: procedure;

/*	This procedure is called to unassign the device  referenced by
   *	the specified RCS entry.  If this device is attached then we will
   *	detach it.
*/
	rcse.disposition = "0"b;			/* Explicit request => always unassign. */

	if rcse.rcse_off ^= "0"b			/* Is device attached? */
	then do;					/* Yes, let rcp_detach_ do everything. */
		arcse_ptr = ptr (rcse_ptr, rcse.rcse_off);
		call rcp_detach_$detach (arcse.rcp_id, "0"b, 0, comment, ecode);
		return;
	     end;

	if rcse.device_off = "0"b			/* Not attached, was it ever assigned? */
	then goto FREE_RCSE;

/*	Device was assigned by rcp_control_.  We must unassign it.
   *	This involves calling rcp_control_ to update RCPD to reflect
   *	the unassignment of this device.  We must also free the RCS entry
   *	used for this assignment.
*/
	operation = access_operations_$rcp_unassign;
	volume_offset = "0"b;
	device_offset = rcse.device_off;
	error_count = 0;
	call rcp_control_ (operation, volume_offset, device_offset,
	     device_name, error_count, process_id, ecode);


	rcse.caller_comment = comment;		/* Put comment in RCS entry. */
	call rcp_comment_ (rcse_ptr);			/* Type caller's comment. */

FREE_RCSE:					/* Free this RCS entry. */
	call rcp_rcse_$free (rcse_ptr, ecode);

     end UNASSIGN_DEVICE;

     end rcp_unassign_;




		    rcp_unload_.pl1                 11/11/89  1110.3rew 11/11/89  0804.6      112797



/****^  ***********************************************************
        *                                                         *
        * 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-01-22,Farley), approve(86-01-22,MCR6979),
     audit(86-03-08,CLJones), install(86-03-21,MR12.0-1033):
     Modified to extend the default IOI timeout during an unload of a FIPS tape
     to include a possible full rewind time. Also changed to wait longer for
     status return.
                                                   END HISTORY COMMENTS */


/* format: style4 */
rcp_unload_: proc (arg_volume_type, arg_volume_name, arg_ecode);


/*

   This program implements the ring 1 support for unloading volumes.
   This includes the operator's unload command and internal interfaces
   such as unloading at detach or device deletion time.


   Created on 04/20/78 by Michael R. Jordan
   Modified on 08/17/78 by Michael R. Jordan
   Modified on 12/09/78 by Michael R. Jordan to provide new internal interface for unloading volumes.
   Modified on 01/29/79 by Michael R. Jordan for MSS0500 subsystem support.
   Modified 6/79 by Michael R. Jordan for MR7.0R.
   Modified 1/85 by Chris Jones to stop using magic numbers.
   Modified 3/85 by Chris Jones to not use device.volume_name after it's cleared.
*/

/*	ARGUMENT DATA		*/


dcl  arg_clear_volume bit (1);			/* ON => clear volume info on unload */
dcl  arg_device_ptr ptr;				/* ptr to RCPD device entry */
dcl  arg_ecode fixed bin (35);			/* status code returned */
dcl  arg_volume_name char (32);			/* name of the volume */
dcl  arg_volume_type char (32);			/* type of volume */


/*	CONSTANT DATA		*/


dcl  UNLOAD_IDCW bit (36) static internal options (constant) init ("720000700201"b3);

dcl  DEFAULT_UNLOAD_TIMEOUT fixed bin (71) static internal options (constant) init (30000000);

dcl  FIPS_UNLOAD_TIMEOUT fixed bin (71) static internal options (constant) init (90000000);


/*	AUTOMATIC DATA		*/


dcl  alarm_channel fixed bin (71);			/* Saved alarm channel. */
dcl  alarm_time fixed bin (71);			/* Saved alarm time. */
dcl  bailout_time fixed bin (71);			/* Max wait time for status. */
dcl  caller_level fixed bin;				/* callers validation level */
dcl  device_off bit (18);				/* offset of rcpd.device entry */
dcl  drive_num fixed bin;				/* The device number of the drive being unloaded. */
dcl  ecode fixed bin (35);				/* local status code */
dcl  event_id fixed bin (71);				/* event id for IOI */
dcl  hit bit (1) aligned;
dcl  i fixed bin;
dcl  ioi_index fixed bin;				/* IOI identifier */
dcl  manual_unload_required bit (1) aligned;		/* "1"b => an error has occured and operator intervention is required. */
dcl  message (4) fixed bin (71);
dcl  volume_name char (32);				/* local copy of volume name */
dcl  volume_type char (32);				/* local copy of volume_type */
dcl  vtypex fixed bin;				/* volume type index */
dcl  wkspc_ptr ptr;					/* Pointer to the workspace for then unload command. */
dcl  sleep_time fixed bin (71);			/* Time we will wait for I/O to complete. */

dcl  1 wait_list aligned,
       2 channel_count fixed bin init (1),		/* Number of channels. */
       2 channel fixed bin (71);			/* Channel to wait on. */


/*	BASED DATA		*/


dcl  1 wkspc aligned based (wkspc_ptr),
       2 idcw bit (36),				/* The rewind/unload idcw. */
       2 status like istat;				/* The status of the operation. */


/*	EXTERNAL DATA		*/


dcl  admin_gate_$ioi_attach entry (fixed bin, char (*) aligned, fixed bin (71), bit (1) aligned, fixed bin (35));
dcl  admin_gate_$ioi_detach entry (fixed bin, fixed bin (35));
dcl  admin_gate_$ioi_set_to_max entry (fixed bin, fixed bin (71), fixed bin (35));
dcl  admin_gate_$syserr entry options (variable);
dcl  cu_$level_get entry (fixed bin);
dcl  cu_$level_set entry (fixed bin);
dcl  cv_dec_ entry (char (*)) returns (fixed bin (35));
dcl  error_table_$media_not_removable fixed bin (35) ext;
dcl  error_table_$volume_busy fixed bin (35) ext;
dcl  error_table_$volume_not_loaded fixed bin (35) ext;
dcl  get_ring_ entry () returns (fixed bin);
dcl  hcs_$get_alarm_timer entry (fixed bin (71), fixed bin (71));
dcl  hcs_$set_alarm_timer entry (fixed bin (71), fixed bin, fixed bin (71));
dcl  ioi_$connect entry (fixed bin, fixed bin, fixed bin (35));
dcl  ioi_$set_status entry (fixed bin, fixed bin (18), fixed bin, fixed bin (35));
dcl  ioi_$timeout entry (fixed bin, fixed bin (71), fixed bin (35));
dcl  ioi_$workspace entry (fixed bin, ptr, fixed bin, fixed bin (35));
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_lock_$lock entry (ptr, fixed bin (35));
dcl  rcp_lock_$unlock entry (ptr);
dcl  rcp_pointers_$data entry () returns (ptr);
dcl  resource_info_$get_vtypex entry (char (*), char (*), fixed bin, fixed bin (35));


/*	BUILTINS AND CONDITIONS	*/


dcl  addr builtin;
dcl  bit builtin;
dcl  cleanup condition;
dcl  clock builtin;
dcl  fixed builtin;
dcl  ptr builtin;
dcl  rel builtin;
dcl  size builtin;
dcl  substr builtin;

/*

   Get the callers validation level and get him set to go.

*/


	call cu_$level_get (caller_level);
	on cleanup begin;
	     call cu_$level_set (caller_level);
	end;
	call cu_$level_set (get_ring_ ());
	ecode = 0;


/*

   Now copy all input arguments.

*/


	volume_type = arg_volume_type;
	volume_name = arg_volume_name;


/*

   Find out what kind of device this volume might be on.

*/


	call resource_info_$get_vtypex (volume_type, volume_type, vtypex, ecode);
	if ecode ^= 0 then goto RETURN;


/*

   Now make sure the device supports volumes and find one with this volume on it.

*/


	rcpd_ptr = rcp_pointers_$data ();		/* get ptr to rcp_data */
	dtype_ptr = addr (rcpd.dtype (vtypex));		/* get device type ptr */
	do device_off = dtype.first_off repeat device.next_off while (device_off ^= "0"b);
	     device_ptr = ptr (rcpd_ptr, device_off);
	     if volume_name = device.volume_name then goto GOT_DEVICE;
	end;

	ecode = error_table_$volume_not_loaded;
	goto RETURN;


/*

   Now lock the data base and unload the volume.

*/


GOT_DEVICE:

	call rcp_lock_$lock (addr (rcpd.lock_info), ecode);
	if ecode ^= 0 then goto RETURN;

	if device.flags.attached then do;		/* This volume is busy! */
	     ecode = error_table_$volume_busy;
	     goto UNLOCK_AND_RETURN;
	end;
	if volume_name ^= device.volume_name then goto UNLOCK_AND_RETURN;

	if device.flags.not_removable_media then do;	/* ERROR */
	     ecode = error_table_$media_not_removable;
	     goto UNLOCK_AND_RETURN;
	end;
	else call UNLOAD_DEVICE ("1"b);


/*

   Now unlock the data base and ...

*/


UNLOCK_AND_RETURN:

	call rcp_lock_$unlock (addr (rcpd.lock_info));


/*

   ... return to the caller.

*/


RETURN:

	arg_ecode = ecode;
	call cu_$level_set (caller_level);

	return;

unload_device: entry (arg_device_ptr, arg_clear_volume);


	device_ptr = arg_device_ptr;			/* copy device ptr */
	rcpd_ptr = rcp_pointers_$data ();		/* get ptr to RCP Data */

	call UNLOAD_DEVICE (arg_clear_volume);		/* unload the device */

	return;

UNLOAD_DEVICE: proc (clear_volume);


dcl  clear_volume bit (1);				/* ON => remove this volume from the device */


	if device.flags.not_removable_media then return;	/* Don't fool with these */

	volume_name = device.volume_name;		/* assure that this is true for later */
	goto STATE (device.state);

STATE (1):					/* ASSIGNED */
	if device.flags.attached then return;


STATE (0):					/* FREE */
STATE (4):					/* RESERVED */
	manual_unload_required = "0"b;		/* initialize */

	call admin_gate_$syserr (0, "RCP: Unloading volume ^[scratch^s^;^a^] from device ^a", (device.volume_name = ""),
	     device.volume_name, device.device_name);

	if clear_volume then do;			/* this volume is being removed from this device */
	     device.volume_name = "";			/* remove it from the device */
	     hit = "0"b;
	     do i = 1 to rcpd.last_volume while (^hit);	/* now find the volume entry */
		volume_ptr = addr (rcpd.volume (i));
		if (volume.volume_name = volume_name) & (volume.state = FREE) then do;
						/* got it */
		     volume.process_id = "0"b;
		     volume.volume_name = "";
		     volume.group_id = "";
		     volume.reserved_by = "";
		     volume.reservation_id = 0;
		     volume.unassign_state = FREE;
		     hit = "1"b;
		end;
	     end;
	end;

	call ipc_$create_ev_chn (event_id, ecode);
	if ecode ^= 0 then goto MANUAL_UNLOAD;

	call admin_gate_$ioi_attach (ioi_index, device.device_name, event_id, "0"b, ecode);
	if ecode ^= 0 then do;			/* cannot do it right */
	     call ipc_$delete_ev_chn (event_id, ecode);	/* delete the enent channel */
	     goto MANUAL_UNLOAD;
	end;

	call ioi_$workspace (ioi_index, wkspc_ptr, size (wkspc), ecode);
	if ecode ^= 0 then do;
	     manual_unload_required = "1"b;
	     goto DETACH;
	end;

/*
   If we are unloading a FIPS tape drive, then we need to allow for the
   case where a rewind is in progress and the FIPS adapter holds onto the
   unload connect till the rewind completes. This is because the tape
   subsystem does not allow the unload, because the rewind has it busy.
*/
	if device.flags.fips then do;
	     call admin_gate_$ioi_set_to_max (ioi_index, FIPS_UNLOAD_TIMEOUT, ecode);
	     if ecode ^= 0 then do;
		manual_unload_required = "1"b;
		goto DETACH;
	     end;
	     call ioi_$timeout (ioi_index, FIPS_UNLOAD_TIMEOUT, ecode);
	     if ecode ^= 0 then do;
		manual_unload_required = "1"b;
		goto DETACH;
	     end;
	end;

	wkspc.idcw = UNLOAD_IDCW;
	drive_num = cv_dec_ (substr (device.device_name, 6, 2));
	addr (wkspc.idcw) -> idcw.device = bit (fixed (drive_num, 6));

	isp = addr (wkspc.status);
	call ioi_$set_status (ioi_index, fixed (rel (isp), 18), 1, ecode);
	if ecode ^= 0 then do;
	     manual_unload_required = "1"b;
	     goto DETACH;
	end;
	istat.completion.st = "0"b;

	call ioi_$connect (ioi_index, 0, ecode);
	if ecode ^= 0 then do;
	     manual_unload_required = "1"b;
	     goto DETACH;
	end;


	sleep_time = rcpd.unload_sleep_time;

	call hcs_$get_alarm_timer (alarm_time, alarm_channel);
						/* save old setting */

	if device.flags.fips then bailout_time = clock () + FIPS_UNLOAD_TIMEOUT;
	else bailout_time = clock () + DEFAULT_UNLOAD_TIMEOUT;

	do while (clock () < bailout_time);
	     call hcs_$set_alarm_timer (sleep_time, 1, event_id);
	     wait_list.channel = event_id;
	     call ipc_$block (addr (wait_list), addr (message), ecode);
	     if istat.completion.st then do;
		if istat.completion.time_out then manual_unload_required = "1"b;
		goto REVERT_ALARM;
	     end;
	end;

	manual_unload_required = "1"b;		/* timed out */
REVERT_ALARM:
	call hcs_$set_alarm_timer (alarm_time, 2, alarm_channel);
						/* revert back to old setting */

DETACH:
	call admin_gate_$ioi_detach (ioi_index, ecode);

	call ipc_$delete_ev_chn (event_id, ecode);	/* delete the event channel created earlier */

	if ^manual_unload_required then return;


MANUAL_UNLOAD:					/* Must tell the operator to do it manually. */
	call admin_gate_$syserr (3, "RCP: Manually unload volume ^a from device ^a", volume_name, device.device_name);
	ecode = 0;				/* show success */
	return;


STATE (2):					/* DELETED */
STATE (3):					/* STORAGE SYSTEM */
	return;


     end UNLOAD_DEVICE;

%include ioi_stat;
%page;
%include iom_pcw;
%page;
%include rcp_com_seg;
%page;
%include rcp_data;
%page;
%include rcp_resource_states;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Unloading volume VOLUME from device DEVICE

   S:	$info

   T:	$run

   M:	The specified VOLUME is being demounted by RCP.

   A:	Return the specified VOLUME to the library.


   Message:
   RCP: Manually unload volume VOLUME from device DEVICE

   S:	$beep

   T:	$run

   M:	RCP could not unload the specified volume from the device on which it was loaded.

   A:	Manually unload the volume from the device and return the volume to the library for storage.


   END MESSAGE DOCUMENTATION */


     end rcp_unload_;




		    rcp_validate_.pl1               11/11/89  1110.3r   11/11/89  0806.7       33228



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


rcp_validate_:  procedure  (arg_rcp_id,arg_caller_level,arg_rcse_ptr,arg_ecode);

/*	This program is an internal interface of RCP.
*	Created on 10/15/74 by Bill Silver.
*
*	This program is called to validate an rcp_id.  If the rcp_id
*	is valid rcp_validate_ will return a pointer to the device
*	entry associated with this rcp_id.  The following tests are
*	made to validate the rcp_id.
*
*	     1.  Check that device offset is within valid bounds.
*	     2.  Check that rcp_id matches the one in the device entry.
*	     3.  Check that this is the process that has the device assigned.
*	     4.  Check that the caller's validation level is not too high.
*	     5.  Check that the RCS entry is in an active state.
*/

dcl	arg_caller_level	fixed bin;	/* (I) Caller's validation level. */
dcl	arg_rcse_ptr	ptr;		/* (O) Pointer to valid rcse entry. */
dcl	arg_ecode		fixed bin(35);	/* (O) error_table_ code. */
dcl	arg_rcp_id	bit(36)  aligned;	/* (I)  rcp_id to validate. */

dcl	dcode		fixed bin(35);	/* Dummy error_table_ code. */
dcl	ecode		fixed bin(35);	/* error_table_ code. */
dcl	process_id	bit(36);		/* ID of calling process. */
dcl	rcp_id		bit(36)  aligned;	/* rcp_id that we are to validate. */
dcl	rcse_off		bit(18);		/* RCS entry offset from rcp_id. */

dcl     (	addr, null, ptr, rel )	builtin;

dcl     (	error_table_$bad_arg,
	error_table_$force_unassign,
	error_table_$bad_index,
	error_table_$bad_processid,
	error_table_$bad_ring_brackets,
	error_table_$invalid_state )  fixed bin(35)  external;

dcl	get_process_id_	entry  returns(bit(36));
dcl	rcp_pointers_$com_seg  entry  returns (ptr);
/*	*/
%include rcp_com_seg;
/*	*/
	ecode = 0;			/* Initialize. */
	rcp_id = arg_rcp_id;		/* Get RCS entry offset from ID to test. */
	rcse_off = addr(rcp_id)->based_rcp_id.rcse_off;
	rcs_ptr = rcp_pointers_$com_seg ();	/* Get pointer to base of RCS. */

	if   (rcse_off = "0"b)  |		/* Test 1:  Check bounds. */
	     (rcse_off > rel(addr(rcs.end)))
	     then do;			/* Not a valid RCS entry offset. */
		ecode = error_table_$bad_index;
		rcse_ptr = null();
		goto VALIDATE_RETURN;
	     end;

	rcse_ptr = ptr(rcs_ptr,rcse_off);	/* Get pointer to RCS entry. */
	if   rcse.rcp_id ^= rcp_id		/* Test 2:  Does rcp_id match? */
	     then do;			/* No. */
		ecode = error_table_$bad_arg;
		goto VALIDATE_RETURN;
	     end;

	if   rcse.process_id ^= get_process_id_()
	     then do;			/* Test 3:  Process ID invalid. */
		ecode = error_table_$bad_processid;
		goto VALIDATE_RETURN;
	     end;

	if   rcse.caller_level < arg_caller_level
	     then do;			/* Test 4:  Level too high. */
		ecode = error_table_$bad_ring_brackets;
		goto VALIDATE_RETURN;
	     end;

	if   rcse.state = 0			/* Test 5:  RCS entry in invalid state. */
	     then if rcse.ecode = error_table_$force_unassign then ecode = rcse.ecode;
	     else ecode = error_table_$invalid_state;

VALIDATE_RETURN:
	arg_ecode = ecode;			/* Return aguments. */
	arg_rcse_ptr = rcse_ptr;		/* Return pointer to RCS entry. */

	end  rcp_validate_;




		    resource_info_.pl1              11/11/89  1110.3r   11/11/89  0807.1      136503



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


resource_info_: proc; return;

/* This subroutine provides an easy way to extract commonly-needed information
   from an RTDT without the calling program having to parse the RTDT itself. */
/*
   Written 04/06/78 by C. D. Tavares
   Modified 6/79 by Michael R. Jordan for MR7.0R to add get_dtypex, get_vtypex, and get_primary_type
   Modified 12/79 by CDT to prevent lossage during cold boots or when >sc1 is not around.
*/

dcl (null, pointer) builtin,
     cleanup condition,
     sysdir char (168) static initial (">system_control_1");

dcl  get_initial_ring_ ext entry returns (fixed bin),
     get_group_id_ ext entry returns (char (32));

%include rtdt;

%include resource_control_desc;

%include rcp_resource_types;

get_type:	entry (resource_type, is_volume_arg, code);

dcl (resource_type char (*),
     is_volume_arg bit (1),
     code fixed bin (35)) parameter;

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	is_volume_arg = rtde.is_volume;

	call term_rtdt (code);
	return;
	
get_primary_type: entry (resource_type, primary_type, code);

	rtdtp = null ();

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	if rtde.flags.is_synonym then primary_type = rtde.syn_to;
	else primary_type = rtde.name;

	call term_rtdt (code);

	return;
	
get_dtypex: entry (resource_type, primary_type, dtypex, code);

dcl  dtypex fixed bin parameter;
dcl  error_table_$device_type_unknown fixed bin (35) ext;
dcl  primary_type char (*) parameter;

	rtdtp = null ();

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	if rtde.flags.is_synonym then primary_type = rtde.syn_to;
	else primary_type = rtde.name;

	call term_rtdt (code);

	do dtypex = hbound (DEVICE_TYPE, 1) to 1 by -1
		while (primary_type ^= DEVICE_TYPE (dtypex));
	end;

	if dtypex = 0 then code = error_table_$device_type_unknown;

	return;
	
get_vtypex: entry (resource_type, primary_type, vtypex, code);

dcl  error_table_$volume_type_unknown fixed bin (35) ext;
dcl  vtypex fixed bin parameter;

	rtdtp = null ();

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	if rtde.flags.is_synonym then primary_type = rtde.syn_to;
	else primary_type = rtde.name;

	call term_rtdt (code);

	do vtypex = hbound (VOLUME_TYPE, 1) to 1 by -1
		while (primary_type ^= VOLUME_TYPE (vtypex));
	end;

	if vtypex = 0 then code = error_table_$volume_type_unknown;

	return;
	
get_rtypex: entry (resource_type, primary_type, rtypex, is_volume_arg, code);

dcl  rtypex fixed bin;

	rtdtp = null ();

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	is_volume_arg = rtde.is_volume;
	if rtde.flags.is_synonym then primary_type = rtde.syn_to;
	else primary_type = rtde.name;

	call term_rtdt (code);

	if is_volume_arg then do rtypex = hbound (VOLUME_TYPE, 1) to 1 by -1
		while (primary_type ^= VOLUME_TYPE (rtypex));
	end;
	else do rtypex = hbound (DEVICE_TYPE, 1) to 1 by -1
		while (primary_type ^= DEVICE_TYPE (rtypex));
	end;

	if rtypex = 0 then code = error_table_$resource_type_unknown;


	return;
	
limits:	entry (resource_type, maxnum_arg, default_arg, time_arg, code);

dcl (maxnum_arg, default_arg, time_arg) fixed bin parameter;

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	maxnum_arg = rtde.process_limit;
	default_arg = rtde.default_time;
	time_arg = rtde.max_time;

	call term_rtdt (code);
	return;
	
mates:	entry (resource_type, n_mates_arg, mates_arg, code);

dcl (n_mates_arg fixed bin,
     mates_arg char (*) dimension (*)) parameter;

dcl (i, j) fixed bin,
    (lbound, dim) builtin,
     error_table_$improper_data_format ext fixed bin (35) static,
     error_table_$unimplemented_version ext fixed bin (35) static,
     error_table_$smallarg ext fixed bin (35) static;

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	n_mates_arg = rtde.n_mates;

	if n_mates_arg > dim (mates_arg, 1) then do;
	     code = error_table_$smallarg;
	     call term_rtdt (0);
	     return;
	end;

	j = lbound (mates_arg, 1);

	do i = 1 to n_mates_arg;
	     mates_arg (j) = rtde.mates (i);
	     j = j + 1;
	end;

	call term_rtdt (code);
	return;
	
defaults:	entry (resource_type, subtype, resource_desc_ptr, resource_no, code);

dcl  subtype char (*) parameter,
     resource_no fixed bin parameter;

dcl 1 master_item aligned like resource_descriptions.item based (mi_ptr);

dcl  mi_ptr pointer,
    (rno, first, last) fixed bin;

dcl  error_table_$resource_type_unknown ext fixed bin (35) static;

dcl  temp_spec bit (36) aligned;


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

	rtdtp = null;

	on cleanup call term_rtdt (0);

	if resource_no = 0 then do;
	     first = 1;
	     last = resource_descriptions.n_items;
	end;

	else first, last = resource_no;

	do rno = first to last;

	     mi_ptr = addr (resource_descriptions.item (rno));

	     call scan_rtdt (resource_type, code);
	     if code ^= 0 then do;
		call term_rtdt (0);
		return;
	     end;

	     master_item.type = resource_type;

	     if subtype ^= "" then do;
		do i = 1 to rtde.n_subtypes while (subtype ^= rtde.subtype_name (i));
		end;

		if i > rtde.n_subtypes then do;
		     code = error_table_$resource_type_unknown;
		     call term_rtdt (0);
		     return;
		end;

		call load_defaults (addr (rtde.subtype_defaults (i)));
	     end;

	     call load_defaults (addr (rtde.registration_defaults));

	     if ^master_item.given.desired_attributes then do;
		call compute_initial_attributes (master_item.potential_attributes, ""b, ""b, master_item.desired_attributes (*));
		master_item.given.desired_attributes = "1"b;
	     end;
	end;

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

load_defaults: proc (default_ptr);

dcl 1 defaults aligned like rtde.registration_defaults based (default_ptr),
     default_ptr pointer;

dcl  temp_potential_atts bit (72) aligned;

	     if ^ master_item.given.potential_attributes then
		if defaults.potential_attributes_given then do;
		     master_item.potential_attributes = defaults.potential_attributes;
		     master_item.given.potential_attributes = "1"b;
		     temp_potential_atts = defaults.potential_attributes;
		end;
		else temp_potential_atts = (72)"1"b;	/* this missing default will cause an error later anyway */
	     else temp_potential_atts = master_item.potential_attributes;

	     if ^ master_item.given.desired_attributes then
		if defaults.attributes_given then do;
		     call compute_initial_attributes (temp_potential_atts, ""b,
			defaults.attributes, master_item.desired_attributes);

		     master_item.given.desired_attributes = "1"b;
		end;

	     if ^ master_item.given.potential_aim_range then
		if defaults.aim_range_given then do;
		     master_item.potential_aim_range (*) = defaults.aim_range (*);
		     master_item.given.potential_aim_range = "1"b;
		end;

	     if ^ master_item.given.charge_type then
		if defaults.charge_type_given then do;
		     master_item.charge_type = get_charge_type (defaults.charge_type);
		     master_item.given.charge_type = "1"b;
		end;

	     return;
	end load_defaults;

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

compute_initial_attributes: proc (potential_attributes, required_attributes, suggested_attributes, resultant_attributes);

dcl (potential_attributes, required_attributes, suggested_attributes) bit (72) aligned parameter,
     resultant_attributes (4) bit (72) aligned parameter;

dcl  choices bit (72) aligned;

	     resultant_attributes (*) = ""b;
	     resultant_attributes (1) = required_attributes;

	     do i = 1 to rtde.n_exclusion_specs;
		choices = rtde.exclusion_specs (i) & potential_attributes;

		temp_spec = choices & required_attributes;
						/* see if any of this group have been constrained */

		if temp_spec = ""b then		/* if not, then */
		     temp_spec = choices & suggested_attributes;
						/* see if any of this group have been suggested */

		if temp_spec ^= ""b then		/* yes, one or the other */
		     j = index (temp_spec, "1"b);	/* choose one at random from suggestion or */
						/* constraint (ideally and usually, there is only one) */
		else j = index (choices, "1"b);	/* no, choose one at random from RTDT */

		substr (resultant_attributes (1), j, 1) = "1"b;
	     end;

	     return;

	end compute_initial_attributes;

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

	call term_rtdt (code);
	return;
	
set_arbitrary_attributes: entry (resource_type, arg_potential_attributes, arbitrary_attributes, code);

dcl  arg_potential_attributes bit (72) aligned parameter,
     arbitrary_attributes (2) bit (72) aligned parameter;

dcl  temp_relatts (4) bit (72) aligned;

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	call compute_initial_attributes (arg_potential_attributes, arbitrary_attributes (2),
	     rtde.registration_defaults.attributes, temp_relatts); /* use protected attributes as constraints */

	arbitrary_attributes (1) = temp_relatts (1);	/* return arbitrary attributes */

	call term_rtdt (code);
	return;
	
lock_on_release: entry (resource_type, lock_sw, code);

dcl  lock_sw bit (1) aligned;

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	lock_sw = rtde.manual_clear;

	call term_rtdt (code);
	return;
	
default_attributes: entry (resource_type, default_attributes, code);

dcl  default_attributes bit (72) aligned parameter;

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	if rtde.registration_defaults.attributes_given then
	     default_attributes = rtde.registration_defaults.attributes;
	else default_attributes = ""b;

	call term_rtdt (code);
	return;
	
canonicalize_name: entry (resource_type, input_name, output_name, code);

dcl (input_name, output_name) char (*) parameter;

dcl  name_buffer char (32),
     entryname_temp char (168);

dcl  cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);

dcl  canonicalizer entry (char (*), char (*), pointer, fixed bin (35)) variable;

/* first, get rid of the canned one */

	if input_name = "scratch" then do;
	     output_name = "scratch";
	     if output_name ^= "scratch" then code = error_table_$smallarg;
	     else code = 0;
	     return;
	end;

	if get_initial_ring_ () = 1 then
	     if get_group_id_ () = "Initializer.SysDaemon.z" then do;
		output_name = input_name;		/* cold boot environment, no cv_entry_ around */
		code = 0;
		return;
	     end;

	rtdtp = null;

	on cleanup call term_rtdt (0);

	call scan_rtdt (resource_type, code);
	if code ^= 0 then do;
	     call term_rtdt (0);
	     return;
	end;

	if rtdt.version = RTDT_version_2 then
	     entryname_temp = "";			/* no canon proc in a version 2 RTDT */
	else entryname_temp = rtde.precanon_proc;
	call term_rtdt (code);

	if entryname_temp = "" then name_buffer = input_name;
						/* no processing desired */

	else do;
	     canonicalizer = cv_entry_ (rtrim (entryname_temp), null, code);
						/* if you give the poor dolt trailing blanks he has a breakdown */
	     if code ^= 0 then return;

	     call canonicalizer (input_name, name_buffer, null, code);
	     if code ^= 0 then return;
	end;

	output_name = name_buffer;

	if output_name ^= name_buffer then code = error_table_$smallarg;
	else code = 0;

	return;
	
test:	entry (new_sysdir);

dcl  new_sysdir char (*) parameter;

	if new_sysdir = "" then sysdir = ">system_control_1";
	else sysdir = new_sysdir;
	return;

scan_rtdt: proc (resource_type_arg, code);

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

dcl  resource_type char (32),
     i fixed bin,
     found bit (1) aligned;

dcl  hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin, fixed bin, pointer, fixed bin (35)),
     sub_err_ ext entry options (variable);

dcl  dirname char (168),
     ename char (32);

	     dirname = sysdir;
	     ename = "rtdt";

	     if get_initial_ring_ () = 1 then
		if get_group_id_ () = "Initializer.SysDaemon.z" then do; /* use the RTDT on the tape to prevent */
		     dirname = ">system_library_1";	/* linkage faults referencing >sss>cv_entry_ */
		     ename = "default_rtmf.rtdt";
		end;

	     call hcs_$initiate (dirname, ename, "", 0, 0, rtdtp, code);
	     if rtdtp = null then do;
		call sub_err_ (code, "resource_info_", "c", null, 0, "Cannot initiate ^a>^a", dirname, ename);
		return;
	     end;

	     if (rtdt.version ^= RTDT_version_2) & (rtdt.version ^= RTDT_version_3) then do;
		code = error_table_$unimplemented_version;
		return;
	     end;
	     code = 0;

	     resource_type = resource_type_arg;

	     do i = 1 to 2;				/* two chances to chase down a synonym */
		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
			if rtde.name = resource_type then
			     if ^rtde.is_synonym then return;
			     else do;
				resource_type = rtde.syn_to;
				found = "1"b;
			     end;
		end;

		if ^found then do;
		     code = error_table_$resource_type_unknown;
		     return;
		end;
	     end;

	     code = error_table_$improper_data_format;
	     return;
	end scan_rtdt;
	
get_charge_type: proc (number) returns (char (32));

dcl  number fixed bin;

	     cttp = pointer (rtdt.charge_type_table_ptr, rtdt.rtdt_area);

	     return (charge_type_table.charge_types (number));
	end get_charge_type;
	
term_rtdt: proc (code);

dcl  code fixed bin (35) parameter;

dcl  hcs_$terminate_noname ext entry (pointer, fixed bin (35));

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

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