



		    PNOTICE_imft.alm                11/14/89  1117.6r w 11/14/89  1117.6        2448



	dec	1			"version 1 structure
	dec	1			"no. of pnotices
	dec	3			"no. of STIs
	dec	56			"lgth of all pnotices + no. of pnotices
          acc       "Copyright, (C) Honeywell Information Systems Inc., 1989"

	aci	"C1IFTM0E0000"
	aci	"C2IFTM0E0000"
	aci	"C3IFTM0E0000"
	end




		    enter_imft_request.pl1          10/14/88  1248.7rew 10/14/88  1211.2      373572



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

/* Submits Inter-Multics File Transfer (IMFT) requests */

/* Created:  April 1982 by G. Palter */
/* Modified: 16 July 1982 by G. Palter to rename "-entry_name" to "-entryname" and correct the error message produced by
   "-target_pathname" when the target pathname is omitted */
/* Modified: March 1983 by Robert Coren to implement "-source" */


/****^  HISTORY COMMENTS:
  1) change(87-11-15,Oke), approve(88-08-01,MCR7948), audit(88-10-11,Farley),
     install(88-10-14,MR12.2-1165):
     Add support for -date_time_after, -skipped and -no_skipped.
  2) change(88-06-22,Beattie), approve(88-08-01,MCR7948),
     audit(88-10-11,Farley), install(88-10-14,MR12.2-1165):
     Add support for -delete, -no_delete, -extend, -replace and -update.
     Changed all access checks to look for explicit ACL entries.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,ifthenstmt,ifthen */

enter_imft_request:
eir:
     procedure () options (variable);

	call cu_$arg_count (n_arguments, code);
	if code ^= 0 then do;			/* not called as a command */
	     call com_err_ (code, ENTER_IMFT_REQUEST);
	     return;
	end;

	if n_arguments = 0 then do;			/* must be given some pathnames */
	     call com_err_$suppress_name (NO_ERROR, ENTER_IMFT_REQUEST, "Usage:  ^a transfer_specs {-control_args}",
		ENTER_IMFT_REQUEST);
	     return;
	end;


/* Establish defaults */

	found_transfer_spec = "0"b;			/* will need at least one of these */

	request_type = imft_default_rqt_ ();		/* tries to find the real name of the default request type */
	foreign_system = after (rtrim (request_type), "To_");
	if foreign_system = ""			/* name not of standard form */
	     then
	     foreign_system = rtrim (request_type);	/* so fake it */
	queue = 0;				/* use the default queue */

	include_files = "1"b;			/* default is to send matching files and subtrees */
	include_subtrees = "1"b;
	file_subtree_arg = "";

	chase_control = DEFAULT_CHASE;		/* chase non-starnames; don't chase starnames */

	long_mode = "1"b;				/* default is -long */
	long_id = "0"b;				/* default is -short_id */
	absolute_pathname = "0"b;			/* default is -entryname */
	notify = "1"b;				/* default is -notify */
	merge_directories = "1"b;			/* default is -merge_directories */
	remote = "0"b;				/* default -s -destination */
	foreign_user = "";				/* default is that user IDs are the same */

	delete_obj = "0"b;				/* default is to not delete */
	extend_seg = "0"b;				/* default is to replace */
	update_seg = "0"b;

	date_time_after = 0;			/* any date */
	list_skipped = "0"b;

	the_argument_list = cu_$arg_list_ptr ();


MAIN_EIR_BLOCK:
	begin;

dcl  is_pathname (n_arguments) bit (1) aligned;

	     is_pathname (*) = "0"b;			/* indicates which arguments are transfer_specs */


/* Scan the argument list, process all control arguments, and validate the syntax of supplied transfer_specs */

	     do argument_idx = 1 to n_arguments;

		call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, the_argument_list);
		if code ^= 0 then do;
		     call com_err_ (code, ENTER_IMFT_REQUEST, "Accessing argument #^d.", argument_idx);
		     return;
		end;

		if index (argument, "-") = 1 then	/* a control argument */
		     if (argument = "-files") | (argument = "-file") | (argument = "-f") then do;
			include_files = "1"b;	/* files only, please */
			include_subtrees = "0"b;
			file_subtree_arg = argument;
		     end;

		     else if (argument = "-subtrees") | (argument = "-subtree") | (argument = "-subt") then do;
			include_subtrees = "1"b;	/* subtrees only, please */
			include_files = "0"b;
			file_subtree_arg = argument;
		     end;

		     else if argument = "-chase" then chase_control = ALWAYS_CHASE;
		     else if argument = "-no_chase" then chase_control = NEVER_CHASE;

		     else if (argument = "-destination") | (argument = "-ds") then do;
			remote = "0"b;
			go to FOREIGN_SYSTEM;
		     end;

		     else if (argument = "-source") | (argument = "-sc") then do;
			remote = "1"b;
FOREIGN_SYSTEM:
			call get_next_argument ("A system name", foreign_system);
			if remote then
			     request_type = "From_" || foreign_system;
			else request_type = "To_" || foreign_system;

			call iod_info_$generic_type (request_type, generic_type, code);
			if code ^= 0 then do;	/* couldn't lookup the specified destination */
INVALID_DESTINATION_SPECIFICATION:
			     if code = error_table_$id_not_found then
				call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST,
				     "Unknown ^[source^;destination^].  ""^a""", remote, foreign_system);
			     else call com_err_ (code, ENTER_IMFT_REQUEST, "-^[source^;destination^] ""^a""",
				     remote, foreign_system);
			     return;
			end;
			if generic_type ^= FT_GENERIC_TYPE then do;
			     call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST,
				"Unknown ^[source^;destination^].  ""^a""", remote, foreign_system);
			     return;
			end;
		     end;

		     else if (argument = "-queue") | (argument = "-q") then do;
			call get_next_argument ("A number", queue_string);
			queue = cv_dec_check_ (queue_string, code);
			if code ^= 0 then do;
INVALID_QUEUE_SPECIFICATION:
			     call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST,
				"The queue must be a number between 1 and 4; not ""^a"".", queue_string);
			     return;
			end;
			if (queue < 1) | (queue > 4) then go to INVALID_QUEUE_SPECIFICATION;
		     end;				/* will check if queue is OK for destination later */

		     else if (argument = "-long") | (argument = "-lg") then long_mode = "1"b;
		     else if (argument = "-brief") | (argument = "-bf") then long_mode = "0"b;

		     else if (argument = "-long_id") | (argument = "-lgid") then long_id = "1"b;
		     else if (argument = "-short_id") | (argument = "-shid") then long_id = "0"b;

		     else if (argument = "-absolute_pathname") | (argument = "-absp") then absolute_pathname = "1"b;
		     else if (argument = "-entryname") | (argument = "-etnm") then absolute_pathname = "0"b;

		     else if (argument = "-notify") | (argument = "-nt") then notify = "1"b;
		     else if (argument = "-no_notify") | (argument = "-nnt") then notify = "0"b;

		     else if (argument = "-merge_directories") | (argument = "-mdr") then merge_directories = "1"b;
		     else if (argument = "-replace_directories") | (argument = "-rpdr") then merge_directories = "0"b;

		     else if (argument = "-foreign_user") | (argument = "-fu") then do;
			call get_next_argument ("A user ID", foreign_user);
			if after (foreign_user, ".") = "" then do;
INVALID_FOREIGN_USER_SPECIFICATION:
			     call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST,
				"Foreign user must be of the form Person.Project; not ""^a"".", foreign_user);
			     return;
			end;
			if after (foreign_user, ".") = "*" then go to INVALID_FOREIGN_USER_SPECIFICATION;
			if before (foreign_user, ".") = "" then go to INVALID_FOREIGN_USER_SPECIFICATION;
			if before (foreign_user, ".") = "*" then go to INVALID_FOREIGN_USER_SPECIFICATION;
			if after (after (foreign_user, "."), ".") ^= "" then
			     go to INVALID_FOREIGN_USER_SPECIFICATION;
		     end;

		     else if (argument = "-target_pathname") | (argument = "-tpn") then do;
			call com_err_ (error_table_$noarg, ENTER_IMFT_REQUEST,
			     """^a"" must be preceded by a pathname.", argument);
			return;
		     end;

/* Process date_time_after, dtaf control */

		     else if (argument = "-date_time_after") | (argument = "-dtaf") then do;
			call get_next_argument ("date_time of last mod", date_time_after_string);
			call convert_date_to_binary_ (date_time_after_string, date_time_after, code);
			if code ^= 0 then do;
			     call com_err_ (code, ENTER_IMFT_REQUEST, "-dtaf time ""^a"" is not valid.",
				date_time_after_string);
			     return;
			end;
		     end;

		     else if (argument = "-skipped") | (argument = "-skpd") then list_skipped = "1"b;

		     else if (argument = "-no_skipped") | (argument = "-nskpd") then list_skipped = "0"b;

		     else if (argument = "-delete") | (argument = "-dl") then delete_obj = "1"b;
		     else if (argument = "-no_delete") | (argument = "-ndl") then delete_obj = "0"b;

		     else if (argument = "-extend") then do;
			extend_seg = "1"b;
			update_seg = "0"b;
			include_files = "1"b;
			include_subtrees = "0"b;
			file_subtree_arg = argument;
		     end;

		     else if (argument = "-replace") | (argument = "-rp") then do;
			extend_seg = "0"b;
			update_seg = "0"b;
			include_files = "1"b;
			file_subtree_arg = argument;
		     end;

		     else if (argument = "-update") | (argument = "-ud") then do;
			extend_seg = "0"b;
			update_seg = "1"b;
			include_files = "1"b;
			include_subtrees = "0"b;
			file_subtree_arg = argument;
		     end;

		     else do;			/* unrecognized control argument */
			call com_err_ (error_table_$badopt, ENTER_IMFT_REQUEST, """^a""", argument);
			return;
		     end;

		else do;				/* a transfer_spec: star_path {-tpn equal_path} */
		     found_transfer_spec = "1"b;
		     is_pathname (argument_idx) = "1"b; /* flag this for later */
		     call expand_pathname_ (argument, local_dirname, local_starname, code);
		     if code ^= 0 then do;
			call com_err_ (code, ENTER_IMFT_REQUEST, "^a", argument);
			return;
		     end;
		     call check_star_name_$entry (local_starname, code);
		     if (code ^= 0) & (code ^= 1) & (code ^= 2) then do;
			call com_err_ (code, ENTER_IMFT_REQUEST, "^a", pathname_ (local_dirname, local_starname));
			return;
		     end;
		     if argument_idx < n_arguments then do;
			call cu_$arg_ptr_rel ((argument_idx + 1), next_argument_ptr, next_argument_lth, code,
			     the_argument_list);	/* peek ahead for -tpn equal_path */
			if code ^= 0 then do;
			     call com_err_ (code, ENTER_IMFT_REQUEST, "Accessing argument #^d.", (argument_idx + 1))
				;
			     return;
			end;
			if (next_argument = "-target_pathname") | (next_argument = "-tpn") then do;
			     argument_idx = argument_idx + 1;
			     argument_ptr = next_argument_ptr;
			     argument_lth = next_argument_lth;
			     call get_next_argument ("A pathname", foreign_pathname);
			     call expand_pathname_ (foreign_pathname, foreign_dirname, foreign_equalname, code);
			     if code ^= 0 then do;
				call com_err_ (code, ENTER_IMFT_REQUEST, "-target_pathname ""^a""",
				     foreign_pathname);
				return;
			     end;
			     call get_equal_name_$check_equal_name_ (foreign_equalname, code);
			     if (code ^= 0) & (code ^= 1) & (code ^= 2) then do;
				call com_err_ (code, ENTER_IMFT_REQUEST, "-target_pathname ""^a""",
				     pathname_ (foreign_dirname, foreign_equalname));
				return;
			     end;
			end;
		     end;
		end;
	     end;

	     if ^found_transfer_spec then do;		/* nothing to transfer (sigh) */
		call com_err_ (error_table_$noarg, ENTER_IMFT_REQUEST, "At least one pathname must be supplied.");
		return;
	     end;

	     if (extend_seg | update_seg) & include_subtrees then do;
		call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST,
		     "The ^[-extend^;-update^] control option cannot be used with the -subtree control option.",
		     extend_seg);
		return;
	     end;

	     call iod_info_$queue_data (request_type, default_queue, max_queues, code);
	     if code ^= 0 then go to INVALID_DESTINATION_SPECIFICATION;

	     if queue = 0 then queue = default_queue;	/* supply default if needed */
	     if queue > max_queues then do;		/* bad queue number for this request type */
		call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST,
		     "^[Source^;Destination^] ^a has only ^d queue^[s^]; you specified queue ^d.", remote,
		     foreign_system, max_queues, (max_queues ^= 1), queue);
		return;
	     end;

	     call iod_info_$driver_access_name (request_type, driver_userid, code);
	     if code ^= 0 then go to INVALID_DESTINATION_SPECIFICATION;


/* Argument parsing completed: open the queue where we will enter the requests and validate our access */

	     system_area_ptr = get_system_free_area_ ();

	     queue_index = 0;			/* for cleanup handler */
	     skipped_count, n_requests_submitted = 0;
	     acl_ptr, star_entry_ptr, star_names_ptr = null ();

	     on condition (cleanup) call cleanup_handler ();

	     queue_ename = rtrim (request_type) || "_" || convert (queue_picture, queue) || ".ms";

	     call message_segment_$open (imft_data_$queue_dirname, queue_ename, queue_index, code);
	     if code ^= 0 then do;
		call com_err_ (code, ENTER_IMFT_REQUEST, "Opening ^a.",
		     pathname_ (imft_data_$queue_dirname, queue_ename));
		go to RETURN_FROM_ENTER_IMFT_REQUEST;
	     end;

	     call message_segment_$get_mode_index (queue_index, queue_mode, code);
	     if code ^= 0 then do;
		call com_err_ (code, ENTER_IMFT_REQUEST, "Determining access to ^a.",
		     pathname_ (imft_data_$queue_dirname, queue_ename));
		go to RETURN_FROM_ENTER_IMFT_REQUEST;
	     end;

	     if (queue_mode & AS_EXTENDED_ACCESS) = AS_EXTENDED_ACCESS then do;
		call message_segment_$get_message_count_index (queue_index, previous_queue_total, code);
		if code ^= 0 then do;
		     call com_err_ (code, ENTER_IMFT_REQUEST, "Determining number of messages in ^a.",
			pathname_ (imft_data_$queue_dirname, queue_ename));
		     go to RETURN_FROM_ENTER_IMFT_REQUEST;
		end;
		have_previous_queue_total = "1"b;
	     end;

	     else if (queue_mode & A_EXTENDED_ACCESS) = A_EXTENDED_ACCESS then have_previous_queue_total = "0"b;

	     else do;				/* not enough access at all */
		call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST, "You do not have permission to use ^a queue ^d.",
		     request_type, queue);
		go to RETURN_FROM_ENTER_IMFT_REQUEST;
	     end;


/* Fill in constant portion of the ft_request */

	     unspec (local_ft_request) = ""b;

	     local_ft_request.header.hdr_version = queue_msg_hdr_version_1;
	     local_ft_request.header.message_type = FT_MESSAGE_TYPE;
	     local_ft_request.header.notify = notify;
	     local_ft_request.header.orig_queue = queue;
	     local_ft_request.header.std_length = currentsize (local_ft_request);

	     local_ft_request.version = FT_REQUEST_VERSION_1;
	     local_ft_request.delete = delete_obj;	/* daemon does deletions, not coordinator */
	     local_ft_request.extend = extend_seg;
	     local_ft_request.update = update_seg;

	     acl_count = 2;				/* one entry each for driver and user */
	     allocate general_acl in (system_area) set (acl_ptr);
	     general_acl.version = GENERAL_ACL_VERSION_1;
	     general_acl.count = acl_count;
	     general_acl (DRIVER_ACL_IDX).access_name = driver_userid;
	     general_acl (USER_ACL_IDX).access_name = get_group_id_$tag_star ();
	     imft_chk_acl.version = IMFT_CHECK_ACL_VERSION_1;
	     imft_chk_acl.foreign_sys_name = foreign_system;
	     imft_chk_acl.gen_acl_ptr = acl_ptr;
	     imft_chk_acl.effective_ring = get_ring_ ();
	     imft_chk_acl.check_aim = "0"b;		/* aim checking done by output daemon */
	     imft_chk_acl.accessfile_pathname = "";

	     if foreign_user ^= "" then do;		/* foreign user is different from local user */
		local_ft_request.foreign_user = foreign_user;
		local_ft_request.foreign_user_given = "1"b;
	     end;

	     if remote then do;			/* request for transfer from other system */
		local_ft_request.remote_transfer = "1"b;
		local_ft_request.include_files = include_files;
		local_ft_request.include_subtrees = include_subtrees;
		local_ft_request.chase_control = chase_control;
	     end;

/* Find each transfer_spec and submit the appropriate requests */

	     have_starname = "0"b;			/* until we know better */
	     do argument_idx = 1 to n_arguments;

		if is_pathname (argument_idx) then do;

		     call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, ignore_code, the_argument_list);
		     call expand_pathname_ (argument, local_dirname, local_starname, ignore_code);

		     local_ft_request.foreign_path_given = "0"b;
		     if argument_idx < (n_arguments - 1) then do;
			call cu_$arg_ptr_rel (argument_idx + 1, argument_ptr, argument_lth, ignore_code,
			     the_argument_list);
			if (argument = "-target_pathname") | (argument = "-tpn") then do;
			     argument_idx = argument_idx + 2;
			     call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, ignore_code,
				the_argument_list);
			     call expand_pathname_ (argument, foreign_dirname, foreign_equalname, ignore_code);
			     local_ft_request.foreign_path_given = "1"b;
			end;
		     end;

		     if ^remote then do;		/* if transferring from here, interpret starname */
			call check_star_name_$entry (local_starname, code);
			have_starname = (code ^= 0);

			if have_starname then do;	/* more than one object */
			     star_entry_ptr, star_names_ptr = null ();
			     skipped_a_request, submitted_a_request, printed_an_error_message = "0"b;
			     if chase_control = ALWAYS_CHASE then
				call hcs_$star_ (local_dirname, local_starname, star_ALL_ENTRIES, system_area_ptr,
				     star_entry_count, star_entry_ptr, star_names_ptr, code);
			     else call hcs_$star_ (local_dirname, local_starname, star_BRANCHES_ONLY,
				     system_area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code);
			     if code ^= 0 then do;
				call com_err_ (code, ENTER_IMFT_REQUEST, "^a",
				     pathname_ (local_dirname, local_starname));
				go to PROCESS_NEXT_TRANSFER_SPEC;
			     end;
			     do entry_idx = 1 to star_entry_count;
				call process_single_request (local_dirname,
				     star_names (star_entries (entry_idx).nindex));
PROCESS_NEXT_STAR_ENTRY:
			     end;
			     free star_names in (system_area);
			     free star_entries in (system_area);
			     star_entry_ptr, star_names_ptr = null ();
			     if (^submitted_a_request & ^skipped_a_request) & ^printed_an_error_message then
				call com_err_ (error_table_$nomatch, ENTER_IMFT_REQUEST, "^a",
				     pathname_ (local_dirname, local_starname));
			end;

			else call process_single_request (local_dirname, local_starname);
		     end;

		     else call process_single_request (local_dirname, local_starname);

PROCESS_NEXT_TRANSFER_SPEC:
		end;
	     end;


/* Print the total number of requests entered if in long mode and cleanup */

RETURN_FROM_ENTER_IMFT_REQUEST:
	     if long_mode & (n_requests_submitted > 0) then
		call ioa_ ("^d request^[s^] submitted^[; ^d already in^; to^s^] ^a queue ^d.", n_requests_submitted,
		     (n_requests_submitted > 1), have_previous_queue_total, previous_queue_total, request_type, queue)
		     ;

CLEANUP:
	     call cleanup_handler ();

	     return;
%page;

/* Performs all necessary processing to submit a single request */

process_single_request:
     procedure (p_dirname, p_ename);

dcl  (p_dirname, p_ename) character (*) parameter;

dcl  (local_dirname, local_pathname, real_dirname, parent_dirname, dirname_here) character (168);
dcl  (local_ename, local_type, real_ename, foreign_ename, parent_ename) character (32);
dcl  message character (512);
dcl  entry_bit_count fixed binary (24);
dcl  entry_type fixed binary (2);
dcl  idx fixed binary;

dcl  request_id character (19);
dcl  the_message_id bit (72) aligned;

dcl  1 stat like status_branch;

	local_dirname = p_dirname;
	local_ename = p_ename;

/* Construct the foreign pathname if -target_pathname was specified */

	if local_ft_request.foreign_path_given then do;
	     if remote then
		foreign_ename = foreign_equalname;	/* don't convert the equal name here */
	     else do;
		call get_equal_name_ (local_ename, foreign_equalname, foreign_ename, code);
		if code ^= 0 then do;
		     call com_err_ (code, ENTER_IMFT_REQUEST, "Applying ^a to ^a.", foreign_equalname, local_ename);
		     go to ABORT_SINGLE_REQUEST;
		end;
	     end;
	end;

	local_pathname = pathname_ (local_dirname, local_ename);
%page;
	if ^remote then do;

/****
      Determine the type of entry and, if requested and the entry is a link,
      determine its actual target.
*/

	     call hcs_$status_long (local_dirname, local_ename, HCS_DONT_CHASE, addr (stat), null (), code);
	     entry_type = stat.type;
	     entry_bit_count = stat.bit_count;
	     if code ^= 0 then do;

COULD_NOT_STATUS_BRANCH:
		call com_err_ (code, ENTER_IMFT_REQUEST, "^a", pathname_ (local_dirname, local_ename));
		go to ABORT_SINGLE_REQUEST;
	     end;

	     if (entry_type = star_LINK) then
		if (^have_starname & (chase_control = DEFAULT_CHASE)) | (chase_control = ALWAYS_CHASE) then do;
		     call hcs_$get_link_target (local_dirname, local_ename, real_dirname, real_ename, code);
		     if code ^= 0 then do;
			call com_err_ (code, ENTER_IMFT_REQUEST, "Determining link target of ^a.",
			     pathname_ (local_dirname, local_ename));
			go to ABORT_SINGLE_REQUEST;
		     end;
		     local_dirname = real_dirname;
		     local_ename = real_ename;
		     local_pathname = pathname_ (local_dirname, local_ename);
		     call hcs_$status_long (local_dirname, local_ename, HCS_DONT_CHASE, addr (stat), null (), code);
		     entry_type = stat.type;
		     entry_bit_count = stat.bit_count;
		     if code ^= 0 then go to COULD_NOT_STATUS_BRANCH;
		end;
		else do;
		     call com_err_ (error_table_$link, ENTER_IMFT_REQUEST, "^a",
			pathname_ (local_dirname, local_ename));
		     go to ABORT_SINGLE_REQUEST;
		end;

/*
   Pass the dtaf screen to determine if we send it.  This will also check
   directories, but not their contents.
*/

	     if ^remote & (cv_fstime_ ((stat.dtcm)) <= date_time_after) then do;
		if list_skipped then
		     call ioa_ ("^[^a^s^;^s^a^] not changed after dtaf.", absolute_pathname, local_pathname,
			local_ename, date_time_after_string);
		skipped_count = skipped_count + 1;
		skipped_a_request = "1"b;
		goto SKIP_THIS_REQUEST;
	     end;
%page;
/****
      Check the user's and the daemon's access to object.  Both must have
      explicit non-null access to the branch.
*/

	     imft_chk_acl.dirname = local_dirname;
	     imft_chk_acl.ename = local_ename;
	     imft_chk_acl.dir_access = S_ACCESS;
	     imft_chk_acl.seg_access = R_ACCESS;
	     imft_chk_acl.bad_acl_idx = USER_ACL_IDX;	/* by default, error is user's */

	     call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	     if code = 0 then code = imft_chk_acl.error_code;
	     if code ^= 0 then
		if code = error_table_$unimplemented_version then do;
		     call com_err_ (code, ENTER_IMFT_REQUEST, BAD_CHK_OBJ_ACL_STR);
		     go to CLEANUP;
		end;
		else do;
		     call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST, "^a^/^2x(^a)",
			imft_chk_acl (imft_chk_acl.bad_acl_idx).error_message, local_pathname);
		     go to ABORT_SINGLE_REQUEST;
		end;

	     do idx = 1 to hbound (general_acl.entries, 1);
		if general_acl (idx).status_code ^= 0 then
		     call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST, "^a^/^2x(^a)", imft_chk_acl (idx).error_message,
			local_pathname);
	     end;

	     if ^imft_chk_acl.allow_transfer | ^imft_chk_acl.objects_to_transfer then go to ABORT_SINGLE_REQUEST;

/* If -file or -subtree was specified, verify that the branch is of the appropriate type */

	     if ^(imft_chk_acl.type = ENTRY_TYPE_DIRECTORY) & ^include_files then do;
		if ^have_starname then
		     call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST,
			"Files may not be specified when ""^a"" is used.  ^a", file_subtree_arg, local_pathname);
		return;
	     end;

	     if (imft_chk_acl.type = ENTRY_TYPE_DIRECTORY) & ^include_subtrees then do;
		if ^have_starname then
		     call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST,
			"Subtrees may not be specified when ""^a"" is used.  ^a", file_subtree_arg, local_pathname);
		return;
	     end;

	     if (extend_seg | update_seg)
		& ^((imft_chk_acl.type = ENTRY_TYPE_SEGMENT) | (imft_chk_acl.type = ENTRY_TYPE_MSF)) then do;

		if index (imft_chk_acl.type, "-") = 1 then
		     local_type = substr (imft_chk_acl.type, 2);
		else local_type = imft_chk_acl.type;

		call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST,
		     "Can only ^[extend^]^[update^] with segments or MSFs, not with ^a type objects:^/^2x^a",
		     extend_seg, update_seg, local_type, local_pathname);
		go to ABORT_SINGLE_REQUEST;
	     end;


	end;					/* if ^remote */
%page;
	if remote & local_ft_request.foreign_path_given	/* in this case, "foreign" path is really local */
	     then
	     dirname_here = foreign_dirname;
	else dirname_here = local_dirname;
	call expand_pathname_ (dirname_here, parent_dirname, parent_ename, ignore_code);

/****
      Must always have S access to containing or parent directory for both
      driver and user.

      If the -delete option was used or local object is being extended or
      updated, both driver and user must have explicit SMA.
*/

	imft_chk_acl.dirname = parent_dirname;
	imft_chk_acl.ename = parent_ename;
	imft_chk_acl.dir_access = S_ACCESS;
	imft_chk_acl.seg_access = R_ACCESS;
	imft_chk_acl.bad_acl_idx = USER_ACL_IDX;	/* by default, error is user's */

	call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	if code = 0 then code = imft_chk_acl.error_code;
	if code ^= 0 then do;
	     if code = error_table_$unimplemented_version then do;
		call com_err_ (code, ENTER_IMFT_REQUEST, BAD_CHK_OBJ_ACL_STR);
		go to CLEANUP;
	     end;
	     call set_dir_s_error_message (imft_chk_acl.bad_acl_idx);
	     call com_err_ (code, ENTER_IMFT_REQUEST, message);
	     go to PROCESS_NEXT_TRANSFER_SPEC;		/* cannot win here for any starname */

	end;					/* if code ^= 0 */

	code = 0;
	do idx = 1 to hbound (general_acl.entries, 1);	/* see if general_acl has any errors to report */
	     if general_acl (idx).status_code ^= 0 then do;
		code = general_acl (idx).status_code;
		call set_dir_s_error_message (idx);
		call com_err_ (code, ENTER_IMFT_REQUEST, message);
	     end;
	end;

	if code ^= 0 then go to PROCESS_NEXT_TRANSFER_SPEC;
						/* cannot win here with any starname */
%page;
	if remote | delete_obj then do;		/* need SMA to parent directory for this case */

	     imft_chk_acl.dir_access = SMA_ACCESS;
	     imft_chk_acl.seg_access = RW_ACCESS;
	     imft_chk_acl.bad_acl_idx = USER_ACL_IDX;	/* by default, error is user's */

	     call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	     if code = 0 then code = imft_chk_acl.error_code;
	     if code ^= 0 then do;
		if code = error_table_$unimplemented_version then do;
		     call com_err_ (code, ENTER_IMFT_REQUEST, BAD_CHK_OBJ_ACL_STR);
		     go to CLEANUP;
		end;
		else do;
		     call set_dir_sma_error_message (imft_chk_acl.bad_acl_idx);
		     call command_query_$yes_no (Yes, code, ENTER_IMFT_REQUEST, explanation,
			"^[^/^2x^]^a" || question, ll_query () < 100, message);
		     if Yes then go to CONTINUE_SINGLE_REQUEST;
		end;
		go to PROCESS_NEXT_TRANSFER_SPEC;	/* cannot win here with any starname */

	     end;					/* if code ^= 0 */

	     code = 0;
	     do idx = 1 to hbound (general_acl.entries, 1);
		if general_acl (idx).status_code ^= 0 then do;
		     code = general_acl (idx).status_code;
		     call set_dir_sma_error_message (idx);
		     call com_err_ (code, ENTER_IMFT_REQUEST, message);
		end;
	     end;

	     if code ^= 0 then do;
		call command_query_$yes_no (Yes, NO_ERROR, ENTER_IMFT_REQUEST, explanation, "^a" || question,
		     "An access error occured.");
		if Yes then go to CONTINUE_SINGLE_REQUEST;
		go to PROCESS_NEXT_TRANSFER_SPEC;	/* cannot win here with any starname */
	     end;


	end;					/* if remote or delete_obj */
%page;
/* Submit the request */

CONTINUE_SINGLE_REQUEST:
	local_ft_request.header.msg_time = clock ();

	local_ft_request.header.dirname = local_dirname;
	local_ft_request.header.ename = local_ename;

	if local_ft_request.foreign_path_given then do;
	     local_ft_request.foreign_dirname = foreign_dirname;
	     local_ft_request.foreign_ename = foreign_ename;
	end;

	if ^remote & (entry_type = star_DIRECTORY) | remote & ^(extend_seg | update_seg) then
	     if merge_directories then		/* record the user's desire for treatment of namedups */
		local_ft_request.directory_creation_mode = MERGE_DIRECTORIES;
	     else local_ft_request.directory_creation_mode = REPLACE_DIRECTORIES;
	else local_ft_request.directory_creation_mode = "00"b;

	call message_segment_$add_index (queue_index, addr (local_ft_request), (36 * currentsize (local_ft_request)),
	     the_message_id, code);
	if code ^= 0 then do;			/* grumble */
	     call com_err_ (code, ENTER_IMFT_REQUEST, "Attempting to add request for ^a.", local_pathname);
	     go to RETURN_FROM_ENTER_IMFT_REQUEST;	/* this is fatal */
	end;

	if long_mode then do;			/* print a message about the success */
	     request_id = request_id_ (local_ft_request.header.msg_time);
	     call ioa_ ("^[^a^s^;^s^a^]; ID: ^[^a^;^s^a^]", absolute_pathname, local_pathname, local_ename, long_id,
		request_id, (substr (request_id, 7, 8)));
	end;

	n_requests_submitted = n_requests_submitted + 1;
	submitted_a_request = "1"b;			/* needed by starname processor */

	return;

/* An error occurred processing this request: proceed to the next one */

ABORT_SINGLE_REQUEST:
	printed_an_error_message = "1"b;		/* needed by starname processor */

SKIP_THIS_REQUEST:
	if have_starname then
	     go to PROCESS_NEXT_STAR_ENTRY;

	else go to PROCESS_NEXT_TRANSFER_SPEC;
%page;
/**** Support internal procedures to construct appropriate error messages. */

set_dir_s_error_message:
	proc (p_idx);

dcl  p_idx fixed binary;

	     if code = error_table_$moderr | code = error_table_$user_not_found then
		call ioa_$rsnnl (
		     "^[^/^2x^]^[Driver^;User^] (^a) must have an explicit ACL entry of S to parent directory of object to be ^[received^s^;^[deleted^;sent^]^].^/^2x(^a)",
		     message, ignore_fb21, ll_query () < 100, (p_idx = DRIVER_ACL_IDX),
		     general_acl (p_idx).access_name, remote, delete_obj, dirname_here);
	     else call ioa_$rsnnl (
		     "^[^/^2x^]Unable to determine S access of ^[driver^;user^] (^a) to the parent directory of object to be ^[received^s^;^[deleted^;sent^]^].^/^2x(^a)",
		     message, ignore_fb21, ll_query () < 100, (p_idx = DRIVER_ACL_IDX),
		     general_acl (p_idx).access_name, remote, delete_obj, dirname_here);

	end set_dir_s_error_message;
%skip (4);
set_dir_sma_error_message:
	proc (p_idx);

dcl  p_idx fixed binary;

	     if code = error_table_$moderr | code = error_table_$user_not_found then
		call ioa_$rsnnl (
		     "^[^/^2x^]^[Driver^;User^] (^a) must have an explicit ACL entry of SMA to parent directory of object to be ^[received^;deleted^].^/^2x(^a)",
		     message, ignore_fb21, ll_query () < 100, (p_idx = DRIVER_ACL_IDX),
		     general_acl (p_idx).access_name, remote, dirname_here);
	     else call ioa_$rsnnl (
		     "^[^/^2x^]Unable to determine SMA access of ^[driver^;user^] (^a) to the parent directory of object to be ^[received^;deleted^].^/^2x(^a)",
		     message, ignore_fb21, ll_query () < 100, (p_idx = DRIVER_ACL_IDX),
		     general_acl (p_idx).access_name, remote, dirname_here);

	end set_dir_sma_error_message;
%skip (4);
     end process_single_request;

	end MAIN_EIR_BLOCK;
%page;

/* Fetch the next argument */

get_next_argument:
     procedure (p_arg_description, p_argument);

dcl  p_arg_description character (*) parameter;
dcl  p_argument character (*) parameter;
dcl  control_argument character (32);

	control_argument = argument;			/* save control arg's name for error messages */

	if argument_idx = n_arguments then do;		/* there is no next argument */
	     call com_err_ (error_table_$noarg, ENTER_IMFT_REQUEST, "^a must follow ""^a"".", p_arg_description,
		control_argument);
	     go to ABORT_ARGUMENT_PARSE;
	end;

	argument_idx = argument_idx + 1;

	call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, the_argument_list);
	if code ^= 0 then do;
	     call com_err_ (code, ENTER_IMFT_REQUEST, "Accessing argument #^d.", argument_idx);
	     go to ABORT_ARGUMENT_PARSE;
	end;

	if argument_lth > length (p_argument) then do;	/* it's too long */
	     call com_err_ (NO_ERROR, ENTER_IMFT_REQUEST,
		"Value after ""^a"" may not be longer than ^d characters.  ""^a""", control_argument,
		length (p_argument), argument);
	     go to ABORT_ARGUMENT_PARSE;
	end;

	p_argument = argument;			/* it's OK */

	return;

     end get_next_argument;

ABORT_ARGUMENT_PARSE:
	return;
%page;
/* Cleanup after an invocation of enter_imft_request */

cleanup_handler:
     procedure ();

	if acl_ptr ^= null () then do;
	     free general_acl in (system_area);
	     acl_ptr = null ();
	end;

	if star_names_ptr ^= null () then do;
	     free star_names in (system_area);
	     star_names_ptr = null ();
	end;

	if star_entry_ptr ^= null () then do;
	     free star_entries in (system_area);
	     star_entry_ptr = null ();
	end;

	if queue_index ^= 0 then do;
	     call message_segment_$close (queue_index, ignore_code);
	     queue_index = 0;
	end;

	return;

     end cleanup_handler;
%skip (4);
/* A little help from eor to help pretty up output. */

ll_query:
     procedure () returns (fixed bin) reducible;

	if line_length_query = 0 then line_length_query = get_line_length_$switch (iox_$user_io, 0);
	return (line_length_query);

     end ll_query;
%page;

/* Sets the directory pathname where the IMFT user commands (eir, lir, mir, cir) will find the request queues */

test_imft:
     entry () options (variable);

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

	if n_arguments = 0 then			/* reset to the default */
	     imft_data_$queue_dirname = imft_data_$default_queue_dirname;

	else if n_arguments = 1 then do;
	     call cu_$arg_ptr (1, argument_ptr, argument_lth, code);
	     if code ^= 0 then do;
		call com_err_ (code, TEST_IMFT, "Accessing argument #1.");
		return;
	     end;
	     call absolute_pathname_ (argument, imft_data_$queue_dirname, code);
	     if code ^= 0 then do;
		call com_err_ (code, TEST_IMFT, "^a", argument);
		return;
	     end;
	end;

	else do;
	     call com_err_$suppress_name (NO_ERROR, TEST_IMFT, "Usage:  ^a {queue_dir_path}", TEST_IMFT);
	     return;
	end;

	call iod_info_$test (imft_data_$queue_dirname);	/* here if we changed it */

	return;
%page;

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  the_argument_list pointer;

dcl  argument character (argument_lth) unaligned based (argument_ptr);
dcl  explain_array (2) char (159) int static options (constant) init ("yes, y
   the request will be submitted, in spite of the problem reported above.
   The caller can take corrective action after the request is submitted,
   or", " can do nothing in the hope that the IMFT daemon will not encounter
   an error.
no, n
   do not submit the request.

Do you still wish to submit the request?");
dcl  explanation char (317) based (addr (explain_array));
dcl  next_argument character (next_argument_lth) unaligned based (next_argument_ptr);
dcl  (argument_lth, next_argument_lth) fixed binary (21);
dcl  (argument_ptr, next_argument_ptr) pointer;
dcl  (n_arguments, argument_idx) fixed binary;

dcl  1 imft_chk_acl aligned like imft_check_acl;
dcl  1 local_ft_request aligned like ft_request;

dcl  foreign_system character (19);
dcl  request_type character (24);
dcl  (generic_type, driver_userid, queue_string, queue_ename) character (32);
dcl  (queue, queue_index, default_queue, max_queues) fixed binary;
dcl  queue_mode bit (36) aligned;
dcl  queue_picture picture "9";

dcl  (local_dirname, foreign_dirname, foreign_pathname) character (168);
dcl  (local_starname, foreign_equalname) character (32);

dcl  foreign_user character (32);
dcl  date_time_after_string character (32);
dcl  date_time_after fixed bin (71);
dcl  file_subtree_arg character (32);
dcl  found_transfer_spec bit (1) aligned;
dcl  remote bit (1) aligned;
dcl  list_skipped bit (1);				/* list dtaf skipped entries */
dcl  skipped_count fixed bin;
dcl  delete_obj bit (1) aligned;
dcl  extend_seg bit (1) aligned;
dcl  update_seg bit (1) aligned;
dcl  (include_files, include_subtrees) bit (1) aligned;
dcl  (long_mode, long_id, absolute_pathname, notify, merge_directories) bit (1) aligned;

dcl  chase_control bit (2) aligned;

dcl  entry_idx fixed binary;
dcl  Yes bit (1) aligned;
dcl  have_starname bit (1) aligned;

dcl  (n_requests_submitted, previous_queue_total) fixed binary;
dcl  (have_previous_queue_total, skipped_a_request, submitted_a_request, printed_an_error_message) bit (1) aligned;

dcl  code fixed binary (35);
dcl  ignore_code fixed binary (35);
dcl  ignore_fb21 fixed binary (21);
dcl  line_length_query fixed binary init (0);

dcl  BAD_CHK_OBJ_ACL_STR character (46) init ("Attempted to call imft_util_$check_object_acl.") static options (constant);
dcl  ENTER_IMFT_REQUEST character (32) static options (constant) initial ("enter_imft_request");
dcl  TEST_IMFT character (32) static options (constant) initial ("enter_imft_request$test_imft");
dcl  NO_ERROR fixed binary (35) static options (constant) initial (0);
dcl  HCS_DONT_CHASE fixed binary (1) static options (constant) initial (0);
dcl  AS_EXTENDED_ACCESS initial ("420000000000"b3) bit (36) aligned static options (constant);
dcl  A_EXTENDED_ACCESS initial ("400000000000"b3) bit (36) aligned static options (constant);
dcl  question char (41) int static options (constant) init ("
Do you still wish to submit the request?");

/* format: on */

dcl  error_table_$badopt fixed binary (35) external;
dcl  error_table_$id_not_found fixed binary (35) external;
dcl  error_table_$link fixed binary (35) external;
dcl  error_table_$moderr fixed binary (35) external;
dcl  error_table_$noarg fixed binary (35) external;
dcl  error_table_$nomatch fixed binary (35) external;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  error_table_$user_not_found fixed binary (35) external;

dcl  imft_data_$queue_dirname character (168) external;
dcl  imft_data_$default_queue_dirname character (168) external;

dcl  absolute_pathname_ entry (character (*), character (*), fixed binary (35));
dcl  check_star_name_$entry entry (character (*), fixed binary (35));
dcl  com_err_ entry () options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  command_query_$yes_no entry () options (variable);
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  cu_$arg_count entry (fixed binary, fixed binary (35));
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl  cv_fstime_ entry (bit (36) aligned) returns (fixed bin (71));
dcl  expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35));
dcl  get_equal_name_ entry (character (*), character (*), character (32), fixed binary (35));
dcl  get_equal_name_$check_equal_name_ entry (character (*), fixed binary (35));
dcl  get_group_id_$tag_star entry () returns (character (32));
dcl  get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl  get_ring_ entry () returns (fixed bin (3));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$get_link_target entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  hcs_$star_
	entry (character (*), character (*), fixed binary (2), pointer, fixed binary, pointer, pointer,
	fixed binary (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  imft_default_rqt_ entry returns (char (*));
dcl  imft_util_$check_object_acl entry (ptr, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$rsnnl entry () options (variable);
dcl  iod_info_$driver_access_name entry (character (*), character (32), fixed binary (35));
dcl  iod_info_$generic_type entry (character (*), character (32), fixed binary (35));
dcl  iod_info_$queue_data entry (character (*), fixed binary, fixed binary, fixed binary (35));
dcl  iod_info_$test entry (character (*));
dcl  iox_$user_io ptr ext static;
dcl  message_segment_$add_index entry (fixed binary, pointer, fixed binary (24), bit (72) aligned, fixed binary (35));
dcl  message_segment_$close entry (fixed binary, fixed binary (35));
dcl  message_segment_$get_message_count_index entry (fixed binary, fixed binary, fixed binary (35));
dcl  message_segment_$get_mode_index entry (fixed binary, bit (36) aligned, fixed binary (35));
dcl  message_segment_$open entry (character (*), character (*), fixed binary, fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  request_id_ entry (fixed binary (71)) returns (character (19));

dcl  cleanup condition;

dcl  (addr, after, before, clock, convert, currentsize, hbound, index, length, null, rtrim, substr, sum, unspec) builtin;
%page;
%include queue_msg_hdr;
%page;
%include "_imft_check_acl";
%page;
%include "_imft_ft_request";
%page;
%include access_mode_values;
%page;
%include acl_structures;
%page;
%include fs_star_;
%page;
%include star_structures;
%include status_structures;
     end enter_imft_request;




		    imft_cir_mir_commands_.pl1      10/14/88  1248.7r w 10/14/88  1214.5      364104



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* Cancels and moves Inter-Multics File Transfer (IMFT) requests */

/* Created:  May 1982 by G. Palter */
/* Modified: 16 July 1982 by G. Palter to make the commands recognize "-a" as the synonym of "-all" */
/* Modified: March 1983 by Robert Coren to recognize "-source" */
/* Modified: July 1984 by C. Marker to search all queues by default. */
 /* Modified: 1984-10-11 BIM for mseg_message_info */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */


imft_cir_mir_commands_:
     procedure ();


dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  1 local_sb aligned like status_branch;
dcl  1 local_mmi aligned like mseg_message_info;

dcl  1 message_ids (n_requests_selected) aligned based (message_ids_ptr),
       2 id bit (72),
       2 queue fixed binary,
       2 pad bit (36);
dcl  message_ids_ptr pointer;
dcl  (n_requests_selected, n_requests_moved, n_previous_requests, message_idx) fixed binary;

dcl  argument character (argument_lth) unaligned based (argument_ptr);
dcl  id_qualifier character (id_qualifier_lth) unaligned based (id_qualifier_ptr);
dcl  (the_argument_list, argument_ptr, id_qualifier_ptr) pointer;
dcl  (argument_lth, id_qualifier_lth) fixed binary (21);
dcl  (n_arguments, id_qualifier_idx, argument_idx) fixed binary;

dcl  function fixed binary (1);			/* whether to cancel or move requests */
dcl  command_name character (32);

dcl  1 n_identifiers aligned,
       2 path fixed binary,				/* # of pathname identifiers */
       2 entry fixed binary,				/* # of -entry STR identifiers */
       2 id fixed binary;				/* # of request ID identifiers */

dcl  (request_type, target_request_type) character (24);
dcl  (foreign_system, target_foreign_system) character (24);
dcl  (
     queue_indeces (4),
     target_queue_index
     ) fixed binary;
dcl  (queue, target_queue, default_queue, max_queues, target_max_queues, queue_idx) fixed binary;
dcl  (remote, target_remote) bit (1) aligned;
dcl  (generic_type, queue_string) character (32);
dcl  (opened_a_queue, all_queues) bit (1) aligned;

dcl  user_selection fixed binary (2);
dcl  long bit (1) aligned;

dcl  (user_id, person_id, project_id) character (32);
dcl  (match_any_person, match_any_project) bit (1) aligned;

dcl  a_dirname character (168);
dcl  an_ename character (32);

dcl  request_id_nonvarying character (19);
dcl  request_id character (19) varying;

dcl  add_entry entry () options (variable) variable;	/* just used to check access */

dcl  access_required bit (36) aligned;

dcl  answer character (16) varying;

dcl  code fixed binary (35);

/* format: off */
dcl (CANCEL	initial (0b),			/* cancel requests */
     MOVE		initial (1b))			/* move requests */
	fixed binary (1) static options (constant);

dcl (USER		initial (01b),			/* -own */
     SUBSET	initial (10b),			/* -user STR: doesn't match any user */
     ALL		initial (11b),			/* -user STR: matches everyone */

     NONE		initial (00b),			/* not a request_identifier control argument */
     PATH		initial (01b),			/* pathname */
     ENTRY	initial (10b),			/* -entry STR */
     ID		initial (11b),			/* -id STR */

     MATCH_ONE	initial (00b),			/* this identifier matches exactly one request */
     MATCH_SUBSET	initial (01b),			/* this identifier matches some but not all requests */
     MATCH_ALL	initial (10b))			/* this identifier matches all requests */
	fixed binary (2) static options (constant);

dcl (A_EXTENDED_ACCESS	initial ("400000000000"b3),
     O_EXTENDED_ACCESS	initial ("040000000000"b3),
     RD_EXTENDED_ACCESS	initial ("300000000000"b3))
	bit (36) aligned static options (constant);
/* format: on */

dcl  CHASE fixed binary (1) static options (constant) initial (1);


dcl  CANCEL_IMFT_REQUEST character (32) static options (constant) initial ("cancel_imft_request");
dcl  MOVE_IMFT_REQUEST character (32) static options (constant) initial ("move_imft_request");

dcl  imft_data_$queue_dirname character (168) external;

/* format: off */
dcl (error_table_$bad_segment, error_table_$badopt, error_table_$id_not_found, error_table_$inconsistent,
     error_table_$moderr, error_table_$no_message, error_table_$no_s_permission, error_table_$noarg)
	fixed binary (35) external;
/* format: on */

dcl  check_star_name_$entry entry (character (*), fixed binary (35));
dcl  com_err_ entry () options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  command_query_ entry () options (variable);
dcl  cu_$arg_count entry (fixed binary, fixed binary (35));
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl  expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  hcs_$status_long entry (character (*), character (*), fixed binary (1), pointer, pointer, fixed binary (35));
dcl  imft_default_rqt_ entry () returns (char (*));
dcl  ioa_ entry () options (variable);
dcl  iod_info_$generic_type entry (character (*), character (32), fixed binary (35));
dcl  iod_info_$queue_data entry (character (*), fixed binary, fixed binary, fixed binary (35));
dcl  match_request_id_ entry (fixed binary (71), character (*)) returns (bit (1) aligned);
dcl  match_star_name_ entry (character (*), character (*), fixed binary (35));
dcl  message_segment_$add_index entry (fixed binary, pointer, fixed binary (24), bit (72) aligned, fixed binary (35));
dcl  message_segment_$close entry (fixed binary, fixed binary (35));
dcl  message_segment_$delete_index entry (fixed binary, bit (72) aligned, fixed binary (35));
dcl  message_segment_$get_message_count_index entry (fixed binary, fixed binary, fixed binary (35));
dcl  message_segment_$get_mode_index entry (fixed binary, bit (36) aligned, fixed binary (35));
dcl  message_segment_$read_message_index entry (fixed binary, pointer, pointer, fixed binary (35));
dcl  message_segment_$open entry (character (*), character (*), fixed binary, fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  queue_admin_$add_index entry (fixed binary, pointer, bit (72) aligned, fixed binary (35));
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  request_id_ entry (fixed binary (71)) returns (character (19));

dcl  (cleanup, linkage_error) condition;

dcl  (addr, after, before, convert, currentsize, index, length, null, rtrim, substr, verify) builtin;

/**/

/* Cancels IMFT requests */

cancel_imft_request:
cir:
     entry () options (variable);

	function = CANCEL;
	command_name = CANCEL_IMFT_REQUEST;
	go to BEGIN_PROCESSING;


/* Moves IMFT requests between queues and even between destinations */

move_imft_request:
mir:
     entry () options (variable);

	function = MOVE;
	command_name = MOVE_IMFT_REQUEST;
	go to BEGIN_PROCESSING;


BEGIN_PROCESSING:
	call cu_$arg_count (n_arguments, code);
	if code ^= 0 then do;
	     call com_err_ (code, command_name);
	     return;
	end;

	if n_arguments = 0 then do;
PRINT_USAGE_MESSAGE:
	     call com_err_$suppress_name (0, command_name, "Usage:  ^a request_identifiers -control_args", command_name)
		;
	     return;
	end;

	the_argument_list = cu_$arg_list_ptr ();


/* Establish defaults */

	n_identifiers = 0;				/* no path, entry, or ID identifiers */

	request_type = imft_default_rqt_ ();		/* gets real name of default request type */
	target_request_type = "";			/* for move: default is to same request type */
	foreign_system = after (request_type, "To_");
	if foreign_system = "" then foreign_system = request_type;
						/* name apparently not of standard form */
	target_foreign_system = foreign_system;		/* reasonable default */
	remote, target_remote = "0"b;
	queue = -1;				/* search all queues by default. */
	target_queue = 0;				/* use default queue */

	user_selection = USER;			/* default is -own */
	long = "1"b;				/* default is -long */

	unspec (local_mmi) = ""b;
	local_mmi.version = MSEG_MESSAGE_INFO_V1;

MAIN_CIR_MIR_BLOCK:
	begin;

dcl  identifier_types (n_arguments) fixed binary (2);	/* type of identifier indicated by this argument */
dcl  star_types (n_arguments) fixed binary (2);		/* type of starname for path and entry identifiers */
dcl  dir_uids (n_arguments) bit (36) aligned;		/* UIDs of directory part of pathname identifiers */

	     identifier_types (*) = NONE;
	     star_types (*) = MATCH_ONE;
	     dir_uids (*) = ""b;
	     id_qualifier_idx = 0;			/* index of first -id STR */


/* Scan the argument list, verify the syntax of all request_identifiers, process all control arguments, and apply other
   appropriate defaults */

	     do argument_idx = 1 to n_arguments;

		call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, the_argument_list);
		if code ^= 0 then do;
		     call com_err_ (code, command_name, "Accessing argument #^d.", argument_idx);
		     return;
		end;

		if index (argument, "-") = 1 then	/* a control argument */
		     if (argument = "-destination") | (argument = "-ds") then do;
			remote = "0"b;
			go to FOREIGN_SYSTEM;
		     end;

		     else if (argument = "-source") | (argument = "-sc") then do;
			remote = "1"b;
FOREIGN_SYSTEM:
			call get_next_argument ("A system name", foreign_system);
			if remote then
			     request_type = "From_" || foreign_system;
			else request_type = "To_" || foreign_system;

			call iod_info_$generic_type (request_type, generic_type, code);
			if code ^= 0 then do;	/* couldn't lookup the specified destination */
INVALID_DESTINATION_SPECIFICATION:
			     if code = error_table_$id_not_found then
				call com_err_ (0, command_name, "Unknown ^[source^;destination^].  ""^a""",
				     remote, foreign_system);
			     else call com_err_ (code, command_name, "-^[source^;destination^] ""^a""", remote,
				     foreign_system);
			     return;
			end;
			if generic_type ^= FT_GENERIC_TYPE then do;
			     call com_err_ (0, command_name, "Unknown ^[source^;destination^].  ""^a""", remote,
				foreign_system);
			     return;
			end;
		     end;

		     else if (argument = "-queue") | (argument = "-q") then do;
			call get_next_argument ("A number", queue_string);
			queue = cv_dec_check_ (queue_string, code);
			if code ^= 0 then do;
INVALID_QUEUE_SPECIFICATION:
			     call com_err_ (0, command_name,
				"The queue must be a number between 1 and 4; not ""^a"".", queue_string);
			     return;
			end;
			if (queue < 1) | (queue > 4) then go to INVALID_QUEUE_SPECIFICATION;
		     end;				/* will check if queue is OK for destination later */

		     else if (argument = "-all") | (argument = "-a") then queue = -1;
						/* special indicator to match all queues */

		     else if (argument = "-long") | (argument = "-lg") then long = "1"b;
		     else if (argument = "-brief") | (argument = "-bf") then long = "0"b;

		     else if argument = "-own" then user_selection = USER;
		     else if argument = "-user" then do;
			call get_next_argument ("A user ID", user_id);
			if after (after (user_id, "."), ".") ^= "" then do;
			     call com_err_ (0, command_name, "Invalid syntax for user ID.  ""^a""", user_id);
			     return;
			end;
			match_any_person = (before (user_id, ".") = "") | (before (user_id, ".") = "*");
			match_any_project = (after (user_id, ".") = "") | (after (user_id, ".") = "*");
			if match_any_person & match_any_project then
			     user_selection = ALL;
			else do;			/* matches a subset of all users */
			     user_selection = SUBSET;
			     person_id = before (user_id, ".");
			     if person_id = "" then person_id = "*";
			     project_id = after (user_id, ".");
			     if project_id = "" then project_id = "*";
			     user_id = rtrim (person_id) || "." || project_id;
			end;
		     end;

		     else if (function = MOVE) & ((argument = "-to_destination") | (argument = "-tods")) then do;
			target_remote = "0"b;
			go to TARGET_FOREIGN_SYSTEM;
		     end;

		     else if (function = MOVE) & ((argument = "-to_source") | (argument = "-tosc")) then do;
			target_remote = "1"b;
TARGET_FOREIGN_SYSTEM:
			call get_next_argument ("A system name", target_foreign_system);
			if target_remote then
			     target_request_type = "From_" || target_foreign_system;
			else target_request_type = "To_" || target_foreign_system;

			call iod_info_$generic_type (target_request_type, generic_type, code);
			if code ^= 0 then do;	/* couldn't lookup the specified destination */
INVALID_TARGET_DESTINATION_SPECIFICATION:
			     if code = error_table_$id_not_found then
				call com_err_ (0, command_name, "Unknown ^[source^;destination^].  ""^a""",
				     target_remote, target_foreign_system);
			     else call com_err_ (code, command_name, "-^[source^;destination^] ""^a""",
				     target_remote, target_foreign_system);
			     return;
			end;
			if generic_type ^= FT_GENERIC_TYPE then do;
			     call com_err_ (0, command_name, "Unknown ^[source^;destination^].  ""^a""",
				target_remote, target_foreign_system);
			     return;
			end;
		     end;

		     else if (function = MOVE) & ((argument = "-to_queue") | (argument = "-tq")) then do;
			call get_next_argument ("A number", queue_string);
			target_queue = cv_dec_check_ (queue_string, code);
			if code ^= 0 then do;
INVALID_TARGET_QUEUE_SPECIFICATION:
			     call com_err_ (0, command_name,
				"The target queue must be a number between 1 and 4; not ""^a"".", queue_string);
			     return;
			end;
			if (target_queue < 1) | (target_queue > 4) then go to INVALID_TARGET_QUEUE_SPECIFICATION;
		     end;				/* will check if queue is OK for destination later */

		     else if (argument = "-entry") | (argument = "-et") then do;
			call get_next_argument ("A starname", an_ename);
			call check_star_name_$entry (an_ename, code);
			if (code ^= 0) & (code ^= 1) & (code ^= 2) then do;
			     call com_err_ (code, command_name, "^a", an_ename);
			     return;
			end;
			n_identifiers.entry = n_identifiers.entry + 1;
			identifier_types (argument_idx) = ENTRY;
			star_types (argument_idx) = code;
		     end;

		     else if argument = "-id" then do;
			call get_next_argument ("A request ID match strin", request_id_nonvarying);
			request_id = rtrim (request_id_nonvarying);
			if verify (request_id, "0123456789.") ^= 0 then do;
INVALID_REQUEST_ID:
			     call com_err_ (0, command_name,
				"Improper syntax for a request ID match string.  ""^a""", request_id);
			     return;
			end;
			if after (after (request_id, "."), ".") ^= "" then go to INVALID_REQUEST_ID;
			if length (before (request_id, ".")) > length ("YYMMDDHHMMSS") then
			     go to INVALID_REQUEST_ID;
			if length (after (request_id, ".")) > length ("FFFFFF") then go to INVALID_REQUEST_ID;
			n_identifiers.id = n_identifiers.id + 1;
			identifier_types (argument_idx) = ID;
			star_types (argument_idx) = MATCH_SUBSET;
			if id_qualifier_idx = 0 then id_qualifier_idx = argument_idx;
		     end;				/* record index of first -id STR */

		     else do;
			call com_err_ (error_table_$badopt, command_name, """^a""", argument);
			return;
		     end;

		else do;				/* a pathname identifier */
		     call expand_pathname_ (argument, a_dirname, an_ename, code);
		     if code ^= 0 then do;
			call com_err_ (code, command_name, "^a", argument);
			return;
		     end;
		     call check_star_name_$entry (an_ename, code);
		     if (code ^= 0) & (code ^= 1) & (code ^= 2) then do;
			call com_err_ (code, command_name, "^a", pathname_ (a_dirname, an_ename));
			return;
		     end;
		     n_identifiers.path = n_identifiers.path + 1;
		     identifier_types (argument_idx) = PATH;
		     star_types (argument_idx) = code;
		     call hcs_$status_long (a_dirname, "", CHASE, addr (local_sb), null (), code);
		     if (code = 0) | (code = error_table_$no_s_permission) then
			dir_uids (argument_idx) = local_sb.uid;
		end;				/* get the UID now: will need it later */
	     end;

	     if (n_identifiers.path + n_identifiers.entry + n_identifiers.id) = 0 then go to PRINT_USAGE_MESSAGE;

	     if ((n_identifiers.path + n_identifiers.entry) > 0) & (n_identifiers.id > 1) then do;
		call com_err_ (error_table_$inconsistent, command_name,
		     "More than one ""-id"" control argument with path/entry identifiers.");
		return;
	     end;

	     call iod_info_$queue_data (request_type, default_queue, max_queues, code);
	     if code ^= 0 then go to INVALID_DESTINATION_SPECIFICATION;
	     if queue = 0 then queue = default_queue;	/* supply default if needed */
	     if queue > max_queues then do;
		call com_err_ (0, command_name, "^[Source^;Destination^] ^a has only ^d queue^[s^]; you specified queue ^d.",
		     remote, request_type, max_queues, (max_queues ^= 1), queue);
		return;
	     end;

	     if function = MOVE then do;		/* apply defaults for -to_destination and -to_queue */
		if (remote & ^target_remote) | (^remote & target_remote) then do;
		     call com_err_ (error_table_$inconsistent, command_name,
			"Cannot move a request ^[from^;to^] a destination queue ^[to^;from^] a source queue.",
			target_remote, target_remote);
		     return;
		end;

		if target_request_type = "" then target_request_type = request_type;
		call iod_info_$queue_data (target_request_type, default_queue, target_max_queues, code);
		if code ^= 0 then go to INVALID_TARGET_DESTINATION_SPECIFICATION;
		if target_queue = 0 then target_queue = default_queue;
		if target_queue > target_max_queues then do;
		     call com_err_ (0, command_name, "^[Source^;Destination^] ^a has only ^d queue^[s^]; you specified queue ^d.",
			target_remote, target_request_type, target_max_queues, (target_max_queues ^= 1), target_queue);
		     return;
		end;
		if (target_request_type = request_type) & (target_queue = queue) then do;
		     call com_err_ (0, command_name,
			"^a queue ^d was specified as the source and target for moving requests.", request_type,
			queue);
		     return;
		end;
	     end;

/**/

/* Fetch the next argument */

get_next_argument:
     procedure (p_arg_description, p_argument);

dcl  p_arg_description character (*) parameter;
dcl  p_argument character (*) parameter;
dcl  control_argument character (32);

	control_argument = argument;			/* save control arg's name for error messages */

	if argument_idx = n_arguments then do;		/* there is no next argument */
	     call com_err_ (error_table_$noarg, command_name, "^a must follow ""^a"".", p_arg_description,
		control_argument);
	     go to ABORT_ARGUMENT_PARSE;
	end;

	argument_idx = argument_idx + 1;

	call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, the_argument_list);
	if code ^= 0 then do;
	     call com_err_ (code, command_name, "Accessing argument #^d.", argument_idx);
	     go to ABORT_ARGUMENT_PARSE;
	end;

	if argument_lth > length (p_argument) then do;	/* it's too long */
	     call com_err_ (0, command_name, "Value after ""^a"" may not be longer than ^d characters.  ""^a""",
		control_argument, length (p_argument), argument);
	     go to ABORT_ARGUMENT_PARSE;
	end;

	p_argument = argument;			/* it's OK */

	return;

     end get_next_argument;

/**/

/* Argument parsing completed: open the appropriate queues and determine if the user has sufficient access */

	     system_area_ptr = get_system_free_area_ ();

	     queue_indeces (*), target_queue_index = 0;	/* for cleanup handler */
	     message_ids_ptr, ft_request_ptr = null ();

	     on condition (cleanup) call cleanup_handler ();

	     if user_selection = USER then do;
		access_required = O_EXTENDED_ACCESS;
		local_mmi.own = "1"b;
	     end;
	     else 				/* user wants to manipulate someone else's requests */
		access_required = RD_EXTENDED_ACCESS;


	     on condition (linkage_error)
		begin;				/* in case the user doesn't have access to queue_admin_ */
		     call com_err_ (0, command_name, "You do not have permission to move other users' requests.");
		     go to RETURN_FROM_CIR_MIR_COMMANDS;
		end;

	     if function = MOVE then			/* moving requests ... */
		if user_selection = USER then		/* ... only moving our own requests */
		     add_entry = message_segment_$add_index;
		else add_entry = queue_admin_$add_index;/* ... moving others' requests: need to preserve user ID */

	     if queue = -1 then do;			/* want to examine all the queues */
		all_queues = "1"b;			/* need to remember this option later */
		opened_a_queue = "0"b;
		do queue_idx = 1 to max_queues;
		     if (function = MOVE) & (request_type = target_request_type) & (queue = target_queue) then
			;			/* won't be moving things out of this queue */
		     else call open_single_queue (request_type, queue_idx, queue_indeces (queue_idx), access_required,
			     "0"b, (0));
		     if queue_indeces (queue_idx) ^= 0 then opened_a_queue = "1"b;
		end;
		if ^opened_a_queue then go to RETURN_FROM_CIR_MIR_COMMANDS;
	     end;

	     else do;				/* just one queue please */
		call open_single_queue (request_type, queue, queue_indeces (queue), access_required, "0"b, (0));
		if queue_indeces (queue) = 0 then go to RETURN_FROM_CIR_MIR_COMMANDS;
	     end;					/* couldn't open it: nothing we can do */

	     if function = MOVE then do;		/* open the target queue */
		call open_single_queue (target_request_type, target_queue, target_queue_index, A_EXTENDED_ACCESS,
		     "1"b, n_previous_requests);
		if target_queue_index = 0 then go to RETURN_FROM_CIR_MIR_COMMANDS;
	     end;

/**/

/* Opens a single queue's message segment, validates access, and returns the number of messages therein if desired */

open_single_queue:
     procedure (p_request_type, p_queue, p_queue_index, p_access_required, p_get_message_count, p_message_count);

dcl  p_request_type character (24) parameter;
dcl  (p_queue, p_queue_index, p_message_count) fixed binary parameter;
dcl  p_access_required bit (36) aligned parameter;
dcl  p_get_message_count bit (1) aligned parameter;

dcl  queue_ename character (32);
dcl  queue_picture picture "9";
dcl  queue_mode bit (36) aligned;

	queue_ename = rtrim (p_request_type) || "_" || convert (queue_picture, p_queue) || ".ms";

	call message_segment_$open (imft_data_$queue_dirname, queue_ename, p_queue_index, code);
	if code ^= 0 then do;
	     call com_err_ (code, command_name, "Opening ^a.", pathname_ (imft_data_$queue_dirname, queue_ename));
	     go to RETURN_FROM_CIR_MIR_COMMANDS;
	end;

	call message_segment_$get_mode_index (p_queue_index, queue_mode, code);
	if code ^= 0 then do;
	     call com_err_ (code, command_name, "Determining access to ^a.",
		pathname_ (imft_data_$queue_dirname, queue_ename));
	     go to RETURN_FROM_CIR_MIR_COMMANDS;
	end;

	if (queue_mode & p_access_required) ^= p_access_required then do;
	     call com_err_ (error_table_$moderr, command_name,
		"You do not have ""^[a^s^;^[o^;rd^]^]"" access to ^a queue ^d.",
		(p_access_required = A_EXTENDED_ACCESS), (p_access_required = O_EXTENDED_ACCESS), p_request_type,
		p_queue);
	     call message_segment_$close (p_queue_index, (0));
	     p_queue_index = 0;			/* caller will decide whether or not to punt */
	end;

	if p_get_message_count then do;
	     call message_segment_$get_message_count_index (p_queue_index, p_message_count, code);
	     if code ^= 0 then p_message_count = -1;	/* let caller know we couldn't tell */
	end;

	return;

     end open_single_queue;

/**/

/* Process the requests identifiers:  For each identifier, construct a list of matching messages.  If the identifier is
   not a starname or if it is a starname path/entry identifier and there is also a request ID qualifier, refuse to cancel
   or move any requests if more than one match is found.  Otherwise, perform the cancel or moves as desired */

	     call get_temp_segment_ (command_name, message_ids_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, command_name, "Getting a temporary segment.");
		go to RETURN_FROM_CIR_MIR_COMMANDS;
	     end;

	     n_requests_moved = 0;			/* haven't moved anything yet */

	     if ((n_identifiers.path + n_identifiers.entry) > 0) & (n_identifiers.id = 1) then
		call cu_$arg_ptr_rel (id_qualifier_idx, id_qualifier_ptr, id_qualifier_lth, (0), the_argument_list);
	     else do;				/* no -id STR qualifier present: avoid faults */
		id_qualifier_ptr = addr (command_name);
		id_qualifier_lth = 0;
	     end;

	     query_info.version = query_info_version_5;
	     query_info.yes_or_no_sw, query_info.suppress_name_sw = "1"b;

	     do argument_idx = 1 to n_arguments;

		if identifier_types (argument_idx) ^= NONE then do;

		     if (id_qualifier = "") | (identifier_types (argument_idx) ^= ID) then do;
						/* don't bother if this is the -id STR qualifier */

			call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, (0), the_argument_list);

			if identifier_types (argument_idx) = PATH then
			     call expand_pathname_ (argument, a_dirname, an_ename, (0));

			if star_types (argument_idx) = MATCH_ALL then do;
			     call command_query_ (addr (query_info), answer, command_name,
				"Do you want to ^[cancel^;move^] all ^[your ^]requests^[ for ^a^;^s^]^[ from directory ^a^;^s^] in ^[all ^;^]^a queue^[ ^d^;s^]?"
				, (function = CANCEL), (user_selection = USER), (user_selection = SUBSET),
				user_id, (identifier_types (argument_idx) = PATH), a_dirname, all_queues,
				request_type, (queue ^= -1), queue);
			     if answer = "no" then go to PROCESS_NEXT_IDENTIFIER;
			end;

			n_requests_selected = 0;

			do queue_idx = 1 to max_queues;
			     if queue_indeces (queue_idx) ^= 0 then call scan_single_queue (queue_idx);
			end;

			if n_requests_selected = 0 then do;
			     if long then		/* nothing found that matches */
				call com_err_ (0, command_name,
				     "No matching requests found in ^a queue^[s^s^; ^d^] for ^[^a^s^s^;^s^[-entry^;-id^] ^a^]^[ -id ^a^]."
				     , request_type, all_queues, queue, (identifier_types (argument_idx) = PATH),
				     pathname_ (a_dirname, an_ename), (identifier_types (argument_idx) = ENTRY),
				     argument, (id_qualifier ^= ""), id_qualifier);
			     go to PROCESS_NEXT_IDENTIFIER;
			end;

			if ((star_types (argument_idx) = MATCH_ONE) | (id_qualifier ^= ""))
						/* non-starname or a qualified starname ... */
			     & (n_requests_selected > 1) then do;
						/* ... should only match one request */
			     call com_err_ (0, command_name,
				"^d matching requests found in ^a queue^[s^s^; ^d^] for ^[^a^s^s^;^s^[-entry^;-id^] ^a^]^[ -id ^a^;^s^]; no requests will be ^[cancelled^;moved^]."
				, n_requests_selected, request_type, all_queues, queue,
				(identifier_types (argument_idx) = PATH), pathname_ (a_dirname, an_ename),
				(identifier_types (argument_idx) = ENTRY), argument, (id_qualifier ^= ""),
				id_qualifier, (function = CANCEL));
			     go to PROCESS_NEXT_IDENTIFIER;
			end;

			do message_idx = 1 to n_requests_selected;
			     if function = CANCEL then
				call cancel_single_request ();
			     else call move_single_request ();
			end;
		     end;
		end;

PROCESS_NEXT_IDENTIFIER:
	     end;

	     if (function = MOVE) & (n_requests_moved > 0) & long then
		call ioa_ ("^d request^[s^] moved^[; ^d already in^;to^s^] ^a queue ^d.", n_requests_moved,
		     (n_requests_moved > 1), (n_previous_requests ^= -1), n_previous_requests, target_request_type,
		     target_queue);

/**/

/* Scan a single queue for matching requests and record their message IDs */

scan_single_queue:
     procedure (p_queue);

dcl  p_queue fixed binary parameter;

dcl  user_id character (30);
dcl  previous_message_id bit (72) aligned;
dcl  request_uid bit (36) aligned;
dcl  retry_read bit (1) aligned;

	retry_read = "0"b;				/* this isn't a retry */

RETRY_FIRST_READ:
	local_mmi.message_code = MSEG_READ_FIRST;
	call message_segment_$read_message_index (queue_indeces (p_queue), system_area_ptr, addr (local_mmi), code);
	if ^retry_read then
	     if code = error_table_$bad_segment then do;
		retry_read = "1"b;			/* queue might have been salvaged: try again */
		go to RETRY_FIRST_READ;
	     end;


	do while (code = 0);			/* while we've got a message */

	     previous_message_id = local_mmi.ms_id;	/* needed to read the next message */

	     ft_request_ptr = local_mmi.ms_ptr;
	     user_id = substr (local_mmi.sender_id, 1, (length (rtrim (local_mmi.sender_id)) - 2));

	     if (ft_request.hdr_version ^= queue_msg_hdr_version_1) | (ft_request.version ^= FT_REQUEST_VERSION_1)
	     then do;				/* unrecognized message format */
		if user_selection = SUBSET then do;	/* ... check if it's from the right user anyway */
		     if person_id ^= "*" then
			if before (user_id, ".") ^= person_id then go to SKIP_THIS_MESSAGE;
		     if project_id ^= "*" then
			if after (user_id, ".") ^= project_id then go to SKIP_THIS_MESSAGE;
		end;
		if (identifier_types (argument_idx) ^= ENTRY) | (star_types (argument_idx) ^= MATCH_ALL) then
		     go to SKIP_THIS_MESSAGE;		/* ... not cancelling/moving any request in the queue */
		go to ADD_THIS_MESSAGE;		/* get here iff it's OK as far as we can tell */
	     end;

	     if user_selection = SUBSET then do;	/* check if it's from the correct user */
		if person_id ^= "*" then
		     if before (user_id, ".") ^= person_id then go to SKIP_THIS_MESSAGE;
		if project_id ^= "*" then
		     if after (user_id, ".") ^= project_id then go to SKIP_THIS_MESSAGE;
	     end;

	     if identifier_types (argument_idx) = PATH then do;
		call match_star_name_ ((ft_request.ename), an_ename, code);
		if code ^= 0 then go to SKIP_THIS_MESSAGE;
		call hcs_$status_long ((ft_request.dirname), "", CHASE, addr (local_sb), null (), code);
		if (code = 0) | (code = error_table_$no_s_permission) then
		     request_uid = local_sb.uid;	/* need UID of directory to test for a match */
		else request_uid = ""b;
		if (request_uid ^= ""b) & (dir_uids (argument_idx) ^= ""b) then
		     if request_uid = dir_uids (argument_idx) then
			;			/* directory UIDs match: this is still a candidate */
		     else go to SKIP_THIS_MESSAGE;
		else if (request_uid = ""b) & (dir_uids (argument_idx) = ""b) then
		     if ft_request.dirname = a_dirname then
			;			/* directory pathnames match */
		     else go to SKIP_THIS_MESSAGE;
		else go to SKIP_THIS_MESSAGE;		/* could get one dir UID but not the other: can't match */
	     end;

	     else if identifier_types (argument_idx) = ENTRY then do;
		call match_star_name_ ((ft_request.ename), argument, code);
		if code ^= 0 then go to SKIP_THIS_MESSAGE;
	     end;					/* entry names only need to match */

	     else do;				/* must be a request ID match string */
		if ^match_request_id_ (ft_request.msg_time, argument) then go to SKIP_THIS_MESSAGE;
	     end;

	     if ((identifier_types (argument_idx) = PATH) | (identifier_types (argument_idx) = ENTRY))
		& (id_qualifier ^= "") then do;	/* further qualified by a request ID match string */
		if ^match_request_id_ (ft_request.msg_time, id_qualifier) then go to SKIP_THIS_MESSAGE;
	     end;

ADD_THIS_MESSAGE:					/* here iff it matches */
	     n_requests_selected = n_requests_selected + 1;
	     message_ids.id (n_requests_selected) = local_mmi.ms_id;
	     message_ids.queue (n_requests_selected) = p_queue;

SKIP_THIS_MESSAGE:
	     free ft_request in (system_area);		/* done with this request for now */
	     ft_request_ptr = null ();

	     retry_read = "0"b;			/* first attempt to read the next message */

RETRY_READ_NEXT_MESSAGE:
	     local_mmi.message_code = MSEG_READ_AFTER_SPECIFIED;
	     local_mmi.ms_id = previous_message_id;
	     call message_segment_$read_message_index (queue_indeces (p_queue), system_area_ptr, addr (local_mmi), code);
	     if ^retry_read then
		if code = error_table_$bad_segment then do;
		     retry_read = "1"b;		/* message segment may have been salvaged */
		     go to RETRY_READ_NEXT_MESSAGE;
		end;
	end;

	if (code ^= 0) & (code ^= error_table_$no_message) then do;
	     call com_err_ (code, command_name, "Reading from ^a queue ^d.", request_type, p_queue);
	     call message_segment_$close (queue_indeces (p_queue), (0));
	     queue_indeces (p_queue) = 0;		/* fatal error while reading: drop this queue */
	end;

	return;

     end scan_single_queue;

/**/

/* Cancel a single IMFT request unless it is already running */

cancel_single_request:
     procedure ();

dcl  user_id character (30);
dcl  message_id bit (72) aligned;
dcl  queue fixed binary;
dcl  (retry_operation, supported_version) bit (1) aligned;

	queue = message_ids.queue (message_idx);	/* make local copies for future reference */
	message_id = message_ids.id (message_idx);

	retry_operation = "0"b;
READ_THE_MESSAGE:
	local_mmi.message_code = MSEG_READ_SPECIFIED;
	local_mmi.ms_id = message_id;
	call message_segment_$read_message_index (queue_indeces (queue), system_area_ptr, addr (local_mmi), code);
	if ^retry_operation then
	     if code = error_table_$bad_segment then do;
		retry_operation = "1"b;		/* message segment has been salvaged */
		go to READ_THE_MESSAGE;
	     end;

	if code ^= 0 then do;			/* couldn't get the message: OK if someone else deleted it */
	     if code ^= error_table_$no_message then
		call com_err_ (code, command_name, "Attempting to read message ^24.3b from ^a queue ^d.", message_id,
		     request_type, queue);
	     return;
	end;

	ft_request_ptr = local_mmi.ms_ptr;
	user_id = substr (local_mmi.sender_id, 1, (length (rtrim (local_mmi.sender_id)) - 2));

	if (ft_request.hdr_version = queue_msg_hdr_version_1) & (ft_request.version = FT_REQUEST_VERSION_1) then do;
	     supported_version = "1"b;		/* understand this request: check if it's running */
	     if ft_request.state = STATE_RUNNING then do;
		call com_err_ (0, command_name,
		     "IMFT request ^a^[ for ^a^;^s^] is already running and will not be cancelled.", ft_request.ename,
		     (user_selection ^= USER), user_id);
		go to RETURN_FROM_CANCEL_SINGLE_REQUEST;
	     end;
	end;
	else supported_version = "0"b;		/* controls the message that's printed */

	retry_operation = "0"b;			/* now to try to delete (cancel) the message */
RETRY_DELETE_MESSAGE:
	call message_segment_$delete_index (queue_indeces (queue), message_id, code);
	if ^retry_operation then
	     if code = error_table_$bad_segment then do;
		retry_operation = "1"b;		/* message segment was salvaged: try again */
		go to RETRY_DELETE_MESSAGE;
	     end;

	if (code ^= 0) & (code ^= error_table_$no_message) then do;
	     call com_err_ (code, command_name,
		"Unable to cancel IMFT request ^[^a^s^;^s^24.3b^]^[ for ^a^;^s^] from ^a queue ^d.",
		supported_version, ft_request.ename, message_id, (user_selection ^= USER), user_id, request_type,
		queue);
	     go to RETURN_FROM_CANCEL_SINGLE_REQUEST;
	end;

	if long & ((star_types (argument_idx) ^= MATCH_ONE) | all_queues) then
	     call ioa_ ("IMFT request ^[^a^s^;^s^24.3b^]^[ for ^a^;^s^] cancelled^[ from queue ^d^].",
		supported_version, ft_request.ename, message_id, (user_selection ^= USER), user_id, all_queues, queue)
		;

RETURN_FROM_CANCEL_SINGLE_REQUEST:
	free ft_request in (system_area);
	ft_request_ptr = null ();

	return;

     end cancel_single_request;

/**/

/* Move a single IMFT request to the target queue unless it is already running */

move_single_request:
     procedure ();

dcl  user_id character (30);
dcl  request_id character (8);
dcl  message_id bit (72) aligned;
dcl  queue fixed binary;
dcl  (retry_operation, supported_version) bit (1) aligned;

	queue = message_ids.queue (message_idx);	/* make local copies for future reference */
	message_id = message_ids.id (message_idx);

	retry_operation = "0"b;
READ_THE_MESSAGE:
	local_mmi.message_code = MSEG_READ_SPECIFIED;
	local_mmi.ms_id = message_id;
	call message_segment_$read_message_index (queue_indeces (queue), system_area_ptr, addr (local_mmi), code);
	if ^retry_operation then
	     if code = error_table_$bad_segment then do;
		retry_operation = "1"b;		/* message segment has been salvaged */
		go to READ_THE_MESSAGE;
	     end;

	if code ^= 0 then do;			/* couldn't get the message: OK if someone else deleted it */
	     if code ^= error_table_$no_message then
		call com_err_ (code, command_name, "Attempting to read message ^24.3b from ^a queue ^d.", message_id,
		     request_type, queue);
	     return;
	end;

	ft_request_ptr = local_mmi.ms_ptr;
	user_id = substr (local_mmi.sender_id, 1, (length (rtrim (local_mmi.sender_id)) - 2));

	if (ft_request.hdr_version = queue_msg_hdr_version_1) & (ft_request.version = FT_REQUEST_VERSION_1) then do;
	     supported_version = "1"b;		/* understand this request: check if it's running */
	     if ft_request.state = STATE_RUNNING then do;
		call com_err_ (0, command_name,
		     "IMFT request ^a^[ for ^a^;^s^] is already running and will not be moved.", ft_request.ename,
		     (user_selection ^= USER), user_id);
		go to RETURN_FROM_MOVE_SINGLE_REQUEST;
	     end;
	end;
	else supported_version = "0"b;		/* controls the message that's printed */

	ft_request.state = STATE_UNPROCESSED;

	if user_selection = USER then
	     call message_segment_$add_index (target_queue_index, ft_request_ptr, (36 * currentsize (ft_request)),
		((72)"0"b), code);
	else call queue_admin_$add_index (target_queue_index, addr (local_mmi), ((72)"0"b), code);

	if code ^= 0 then do;			/* couldn't move the request (sigh) */
	     call com_err_ (code, command_name,
		"Unable to move IMFT request ^[^a^s^;^s^24.3b^]^[ for ^a^;^s^] from ^a queue ^d to ^[^a ^;^s]queue ^d."
		, supported_version, ft_request.ename, message_id, (user_selection ^= USER), user_id, request_type,
		queue, (request_type ^= target_request_type), target_request_type, target_queue);
	     go to RETURN_FROM_MOVE_SINGLE_REQUEST;
	end;

	n_requests_moved = n_requests_moved + 1;	/* it now counts as being moved */

	if long then do;
	     request_id = substr ((request_id_ (ft_request.msg_time)), 7, 8);
	     call ioa_ ("IMFT request ^[^a^s^;^s^24.3b^]^[ for ^a^;^s^] moved from ^a queue ^d; ID: ^a.",
		supported_version, ft_request.ename, message_id, (user_selection ^= USER), user_id, request_type,
		queue, request_id);
	end;					/* target destination/queue are given in summary message */

	retry_operation = "0"b;			/* now to try to delete the original copy */
RETRY_DELETE_MESSAGE:
	call message_segment_$delete_index (queue_indeces (queue), message_id, code);
	if ^retry_operation then
	     if code = error_table_$bad_segment then do;
		retry_operation = "1"b;		/* message segment was salvaged: try again */
		go to RETRY_DELETE_MESSAGE;
	     end;

	if (code ^= 0) & (code ^= error_table_$no_message) then
	     call com_err_ (code, command_name,
		"IMFT request ^[^a^s^;^s^24.3b^]^[ for ^a^;^s^] added to ^a queue ^d but could not be deleted from ^a queue ^d."
		, supported_version, ft_request.ename, message_id, (user_selection ^= USER), user_id,
		target_request_type, target_queue, request_type, queue);

RETURN_FROM_MOVE_SINGLE_REQUEST:
	free ft_request in (system_area);
	ft_request_ptr = null ();

	return;

     end move_single_request;

	end MAIN_CIR_MIR_BLOCK;

/**/

RETURN_FROM_CIR_MIR_COMMANDS:
	call cleanup_handler ();

ABORT_ARGUMENT_PARSE:
	return;


/* Cleanup after an invocation of cancel_imft_request or move_imft_request */

cleanup_handler:
     procedure ();

	if ft_request_ptr ^= null () then do;
	     free ft_request in (system_area);
	     ft_request_ptr = null ();
	end;

	if message_ids_ptr ^= null () then do;
	     call release_temp_segment_ (command_name, message_ids_ptr, (0));
	     message_ids_ptr = null ();
	end;

	do queue_idx = 1 to max_queues;
	     if queue_indeces (queue_idx) ^= 0 then do;
		call message_segment_$close (queue_indeces (queue_idx), (0));
		queue_indeces (queue_idx) = 0;
	     end;
	end;

	if target_queue_index ^= 0 then do;
	     call message_segment_$close (target_queue_index, (0));
	     target_queue_index = 0;
	end;

	return;

     end cleanup_handler;

/**/

%include mseg_message_info;
%page;
%include queue_msg_hdr;
%page;
%include "_imft_ft_request";
%page;
%include status_structures;
%page;
%include query_info;

     end imft_cir_mir_commands_;




		    imft_convert_status_code_.pl1   10/27/88  1310.7rew 10/27/88  1309.8       45954



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

/* Encodes/decodes status codes in imft_et_ into/from forms which may be transmitted between systems */

/* Created:  April 1982 by G. Palter */
/* Modified: July 1982 by G. Palter as part of true AIM support */


/****^  HISTORY COMMENTS:
  1) change(88-10-26,Beattie), approve(88-08-01,PBF7948),
     audit(88-10-27,Farley), install(88-10-27,MR12.2-1195):
     Added support for imft_et_$non_matching_versions in 4.0 version of
     IMFT driver.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,ifthenstmt,ifthen */

imft_convert_status_code_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_local_code fixed binary (35) parameter;		/* encode */
dcl  P_remote_code fixed binary (35) parameter;		/* decode */


/* Remaining declarations */

/* format: off */
dcl (error_table_$ai_no_common_max, error_table_$ai_outside_common_range, error_table_$unimplemented_version,
     imft_et_$cant_access_pnt, imft_et_$cant_get_channel_names, imft_et_$computed_ceiling_mismatch,
     imft_et_$explicit_ceiling_mismatch, imft_et_$explicit_floor_mismatch, imft_et_$no_card_password, imft_et_$no_person_id, imft_et_$non_matching_ids,
     imft_et_$non_matching_passwords, imft_et_$not_synchronized, imft_et_$process_authorization_too_low,
     imft_et_$reply_pending, imft_et_$timeout, imft_et_$unknown_status_code, imft_et_$non_matching_versions)
	fixed binary (35) external;
/* format: on */

/**/

/* Converts a status code from imft_et_ into a form which may be transferred across an IMFT link */

encode:
     entry (P_local_code) returns (fixed binary (35));

	if P_local_code = 0 then return (0);
	else if P_local_code = error_table_$ai_no_common_max then return (1);
	else if P_local_code = error_table_$ai_outside_common_range then return (2);
	else if P_local_code = error_table_$unimplemented_version then return (3);
	else if P_local_code = imft_et_$cant_access_pnt then return (4);
	else if P_local_code = imft_et_$computed_ceiling_mismatch then return (5);
	else if P_local_code = imft_et_$explicit_ceiling_mismatch then return (6);
	else if P_local_code = imft_et_$no_card_password then return (7);
	else if P_local_code = imft_et_$no_person_id then return (8);
	else if P_local_code = imft_et_$non_matching_ids then return (9);
	else if P_local_code = imft_et_$non_matching_passwords then return (10);
	else if P_local_code = imft_et_$not_synchronized then return (11);
	else if P_local_code = imft_et_$process_authorization_too_low then return (12);
	else if P_local_code = imft_et_$reply_pending then return (13);
	else if P_local_code = imft_et_$timeout then return (14);
	else if P_local_code = imft_et_$cant_get_channel_names then return (15);
	else if P_local_code = imft_et_$explicit_floor_mismatch then return (16);
	else if P_local_code = imft_et_$non_matching_versions then return (17);
	else if P_local_code = imft_et_$unknown_status_code then return (-1);
	else return (-1);				/* unrecognized code */



/* Converts a code received from the remote system back into a status code in imft_et_ */

decode:
     entry (P_remote_code) returns (fixed binary (35));

	if P_remote_code = 0 then return (0);
	else if P_remote_code = 1 then return (error_table_$ai_no_common_max);
	else if P_remote_code = 2 then return (error_table_$ai_outside_common_range);
	else if P_remote_code = 3 then return (error_table_$unimplemented_version);
	else if P_remote_code = 4 then return (imft_et_$cant_access_pnt);
	else if P_remote_code = 5 then return (imft_et_$computed_ceiling_mismatch);
	else if P_remote_code = 6 then return (imft_et_$explicit_ceiling_mismatch);
	else if P_remote_code = 7 then return (imft_et_$no_card_password);
	else if P_remote_code = 8 then return (imft_et_$no_person_id);
	else if P_remote_code = 9 then return (imft_et_$non_matching_ids);
	else if P_remote_code = 10 then return (imft_et_$non_matching_passwords);
	else if P_remote_code = 11 then return (imft_et_$not_synchronized);
	else if P_remote_code = 12 then return (imft_et_$process_authorization_too_low);
	else if P_remote_code = 13 then return (imft_et_$reply_pending);
	else if P_remote_code = 14 then return (imft_et_$timeout);
	else if P_remote_code = 15 then return (imft_et_$cant_get_channel_names);

	else if P_remote_code = 16 then return (imft_et_$explicit_floor_mismatch);
	else if P_remote_code = 17 then return (imft_et_$non_matching_versions);
	else if P_remote_code = -1 then return (imft_et_$unknown_status_code);
	else return (imft_et_$unknown_status_code);	/* an unknown code got through */

     end imft_convert_status_code_;




		    imft_data_.cds                  05/28/82  1229.1rew 05/27/82  1552.3       18027



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* Constants and static data used internally by the Inter-Multics File Transfer (IMFT) Facility */

/* Created:  May 1982 by G. Palter */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */


imft_data_:
     procedure () options (variable);


dcl  1 imft_constants aligned,			/* the constant data */
       2 default_queue_dirname character (168);

dcl  1 imft_static aligned,				/* static variables (may be changed during testing) */
       2 queue_dirname character (168);

dcl  1 cds_data aligned like cds_args;

dcl  code fixed binary (35);

dcl  IMFT_DATA_ character (32) static options (constant) initial ("imft_data_");

dcl  com_err_ entry () options (variable);
dcl  create_data_segment_ entry (pointer, fixed binary (35));

dcl  (addr, currentsize, null, string) builtin;


	imft_constants.default_queue_dirname = ">daemon_dir_dir>io_daemon_dir";

	imft_static.queue_dirname = imft_constants.default_queue_dirname;

	cds_data.sections (1).p = addr (imft_constants);
	cds_data.sections (1).len = currentsize (imft_constants);
	cds_data.sections (1).struct_name = "imft_constants";

	cds_data.sections (2).p = addr (imft_static);
	cds_data.sections (2).len = currentsize (imft_static);
	cds_data.sections (2).struct_name = "imft_static";

	cds_data.seg_name = IMFT_DATA_;
	cds_data.num_exclude_names = 0;
	cds_data.exclude_array_ptr = null ();

	string (cds_data.switches) = ""b;
	cds_data.switches.have_text = "1"b;		/* have constants ... */
	cds_data.switches.have_static = "1"b;		/* ... and static data */

	call create_data_segment_ (addr (cds_data), code);
	if code ^= 0 then call com_err_ (code, IMFT_DATA_);

	return;

/**/

%include cds_args;

     end imft_data_;




		    imft_default_rqt_.pl1           10/14/88  1248.7r w 10/14/88  1214.4       18630



/* format: style4,delnl,insnl,^ifthendo */
imft_default_rqt_:
     procedure returns (character (*));

/* This function returns the name of the default IMFT request type. It does this by
   listing the names on imft_1.ms and looking for one of the form "To_<Site>_1.ms".
   If it can't find any such, it returns the last name it found that wasn't "imft"; if
   the only name on the queue is imft_1.ms, then it returns "imft". It also returns "imft"
   if it can't find the names for some reason.

   Someday IMFT will use the "default_generic_queue" field of the queue_group_table entry,
   and this kludge can go away.
*/

/* Written March 1983 by Robert Coren */

dcl  code fixed bin (35);
dcl  best_bet char (32);
dcl  entry_name char (32);
dcl  i fixed bin;

dcl  imft_data_$queue_dirname external static char (168);

dcl  hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));

dcl  (before, reverse, rtrim, substr) builtin;


dcl  1 auto_status aligned like status_branch;

dcl  auto_area area (1024);


	status_ptr = addr (auto_status);
	status_area_ptr = addr (auto_area);

	call hcs_$status_ (imft_data_$queue_dirname, rtrim (FT_GENERIC_TYPE) || "_1.ms", 1, status_ptr, status_area_ptr,
	     code);
	if code ^= 0				/* punt */
	then return (FT_GENERIC_TYPE);

	best_bet = FT_GENERIC_TYPE;			/* in case we can't find anything better */

	do i = 1 to status_branch.nnames;
	     entry_name = status_entry_names (i);
	     if substr (reverse (rtrim (entry_name)), 1, 5) = reverse ("_1.ms")
	     then do;				/* ignore names that aren't even proper queue names */

		entry_name = before (entry_name, "_1.ms");
		if substr (entry_name, 1, 3) = "To_"	/* this is a reasonable one */
		then return (entry_name);

		else if entry_name ^= FT_GENERIC_TYPE
		then best_bet = entry_name;
	     end;
	end;

/* if we fell through, we didn't find the ideal name, so let's use the best we found */

	return (best_bet);
%page;
%include status_structures;
%page;
%include "_imft_ft_request";
%page;
%include queue_msg_hdr;

     end imft_default_rqt_;




		    imft_driver_.pl1                10/28/88  1409.0rew 10/28/88  1257.4      995283



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

/* Inter-Multics File Transfer Daemon */

/* Created:  October 1980 by G. Palter using hasp_ws_sim_driver_ as a base */
/* Modified: 24 September 1981 by G. Palter to perform synchronization and automatically start processing requests */
/* Modified: April 1982 by G. Palter to complete initial implementation */
/* Modified: July 1982 by G. Palter to accept "indirect=<pathname>" keyword and implement true AIM support */
/* Modified: February 1983 by Robert Coren to accept "-io_description" as alternative to "-input_description" and
   "-output_description", and to process "version" keyword */
/* Modified: March 1983 by Robert Coren to set up for 2 minor devices for output driver (for remote requests)
   and to make "yes_no_p" tell whether it was yes or no */
/* Modified: 28 April 1983 by G. Palter to make the indirect keyword accept archive component pathnames */
/* Modified: August 1983 by Robert Coren to handle minimum access class */
/* Modified: 1984-09-17 by E. Swenson to remove call to pnt_manager_$test. */
/* Modified: February 23, 1985 by C. Marker to use version 5 message segments */

/****^  HISTORY COMMENTS:
  1) change(87-11-15,Oke), approve(88-08-01,MCR7948), audit(88-10-11,Farley),
     install(88-10-14,MR12.2-1165):
     a. Permit use as an in-dial/out-dial daemon using a data protocol to
        establish the connection.
     b. Numerous minor bug fixes and cleanups, such as releasing attribute
        storage which was allocated.
     c. Add line_speed command for a driver.  Permit receiver to be out-dial
        and transmitter as in-dial.  Reduce instances of having to reinitialize
        due to line detachment by resectioning code and permitting line
        reattachment and synchronization.
  2) change(88-06-20,Beattie), approve(88-08-01,MCR7948),
     audit(88-10-11,Farley), install(88-10-14,MR12.2-1165):
     a. Internal date time routine replaced with date_time_$format calls.
     b. Add support for min_time_est_msg keyword.
     c. Prevent driver from initializing if execution ring less than 4.
  3) change(88-08-20,Brunelle), approve(88-08-19,MCR7911),
     audit(88-10-26,Wallman), install(88-10-28,MR12.2-1199):
     Upgrade to version 5 iod tables.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */

imft_driver_:
     procedure ();

	return;					/* not an entry */
%page;
/* Initialize the driver */

init:
     entry (P_stat_p);

/****
      Extended object access checks get more complicated when the driver is
      executing in a ring lower than 4.  This restriction is not seen as a
      problem since it is expected that sites are running their daemons in a
      ring 4 process.  This prevents mailboxes, PNTs, DM files, etc, from being
      handled by an IMFT connection.
*/

	my_ring = get_ring_ ();
	if my_ring < 4 then do;
	     call iodd_msg_ (ERROR, MASTER, error_table_$fatal_error, IMFT_DRIVER_,
		"The IMFT driver must be executing in a ring not less than 4.");
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	stat_p = P_stat_p;
	static_pause_time = 10;			/* need to set the default somewhere */

	text_strings_ptr = iodd_static.text_strings_ptr;	/* get ptr to i/o daemon table text area */

	if iodd_static.attach_type ^= ATTACH_TYPE_TTY then do;
						/* this driver expects a tty channel */

BAD_LINE_STATEMENT:
	     call iodd_msg_ (ERROR, MASTER, error_table_$fatal_error, IMFT_DRIVER_,
		"The IMFT driver must be defined with a ""line: *;"" statement.");
	     return;				/* quit now */
	end;

	if iodd_static.attach_name ^= "*" then go to BAD_LINE_STATEMENT;

	if iodd_static.slave.active then do;		/* no slave device allowed */
	     call iodd_msg_ (ERROR, MASTER, error_table_$fatal_error, IMFT_DRIVER_,
		"The IMFT driver does not accept slave terminals.");
	     return;
	end;

	iodd_static.dev_io_stream, iodd_static.dev_in_stream = "Undefined_stream!";
						/* not used by this driver */

	ds_ptr = iodd_static.driver_ptr;		/* preset by iodd_ */
	ds_ptr -> driver_status.dev_out_iocbp, ds_ptr -> driver_status.dev_in_iocbp = null ();
	ds_ptr -> driver_status.dev_out_stream, ds_ptr -> driver_status.dev_in_stream = "null_stream";
	ds_ptr -> driver_status.dev_ctl_ptr = null ();

	ds_ptr -> driver_status.bit_rate_est,		/* no output rate defined yet */
	     ds_ptr -> driver_status.defer_time_limit = 0;/* make operator specify */

	saved_test_entry = iodd_static.test_entry;	/* will restore before returning to iodd_ */
	major_args_ptr = null ();			/* for cleanup handler */
	send_logout_record = "1"b;			/* tell the other side about ordinary logouts */
	dma.dial_channel = 0;

/* Establish initial condition of aim_attributes_ptr to ensure allocated
   storage is freed. */

	static.local_system.aim_attributes_ptr = null ();
	static.foreign_system.aim_attributes_ptr = null ();
	static.dial_service = ""b;			/* not a dial protocol */

	on condition (daemon_logout), condition (daemon_new_device), condition (no_coord)
	     begin;
	     if send_logout_record then do;		/* don't tell other side if they told us */
		local_icri.record_type = IMFT_LOGOUT;
		local_icri.version = ICRI_VERSION_1;
		local_icri.timeout = 15;		/* ... doesn't really have to get through */
		local_icri.record_ptr = null ();	/* ... no associated data */
		local_icri.record_lth, local_icri.record_max_lth = 0;
		if static.input_driver then		/* ... be sure to issue proper type of control order */
		     if ds_ptr -> driver_status.dev_in_iocbp ^= null () then
			call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "write_reply_record",
			     addr (local_icri), ignore_code);
		     else ;			/* ... no connection to the remote system yet */
		else if ds_ptr -> driver_status.dev_out_iocbp ^= null () then do;
		     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "write_command_record",
			addr (local_icri), ignore_code);
		     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "runout", null (), ignore_code);
		end;				/* ... make sure the record gets through before the hangup */
	     end;
	     iodd_static.test_entry = saved_test_entry;
	     if (major_args_ptr ^= null ())
		& (major_args_ptr
		^= add_char_offset_ (addr (text_strings.chars), iodd_static.major_args.first_char - 1)) then
		call terminate_file_ (major_args_ptr, 0, TERM_FILE_TERM, ignore_code);
	     call drop_device ();
	end;

	on condition (daemon_slave_logout) go to LOGOUT_SLAVE;

	on condition (cleanup)
	     begin;
	     iodd_static.test_entry = saved_test_entry;
	     if (major_args_ptr ^= null ())
		& (major_args_ptr
		^= add_char_offset_ (addr (text_strings.chars), iodd_static.major_args.first_char - 1)) then
		call terminate_file_ (major_args_ptr, 0, TERM_FILE_TERM, ignore_code);
	     call detach_device ();
	     call free_aim_attributes_storage;
	     iodd_static.attach_name = "*";
	end;

	on condition (imft_remote_logout_)
	     begin;
	     send_logout_record = "0"b;		/* they told us so we shouldn't tell them ... */
	     call iodd_msg_ (NORMAL, MASTER, 0, IMFT_DRIVER_,
		"^a's ^[output^;input^] driver disconnected; local driver will ^[wait for reconnection^;logout^].",
		static.foreign_system.name, static.input_driver, static.automatic_operation);
	     if static.automatic_operation then do;
		if static.dial_service then do;
		     call drop_device;
		     call attach_and_init_line;	/* restablish link */
		end;
		go to RESYNCHRONIZE_DRIVER;
	     end;
	     else signal condition (daemon_logout);	/* ... will never return (we hope) */
	end;

	on condition (imft_resynchronize_driver_)
	     begin;
	     call iodd_msg_ (LOG, MASTER, 0, "", "^a requested resynchronization.", static.foreign_system.name);
	     if static.input_driver then do;		/* must get the SYNC1 command retransmitted */
		local_icri.version = ICRI_VERSION_1;
		local_icri.timeout = 15;		/* don't have to wait for this to finish */
		local_icri.record_type = IMFT_RESYNCHRONIZE;
		local_icri.record_ptr = null ();
		local_icri.record_lth, local_icri.record_max_lth = 0;
		if ds_ptr -> driver_status.dev_in_iocbp ^= null () then
		     call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "write_reply_record", addr (local_icri),
			code);
	     end;
	     go to RESYNCHRONIZE_DRIVER;
	end;

	on condition (imft_debug_)
	     begin;				/* lets a programmer see what's wrong */
	     call iodd_msg_ (NORMAL, MASTER, 0, IMFT_DRIVER_,
		"Driver detected a condition which requires programmer intervention.");
	     call iodd_quit_handler_$command_level ();
	end;

	on condition (re_init)
	     begin;				/* driver is reinitializing */
	     if static.input_driver then do;		/* make the output driver aware that we're restarting */
		local_icri.version = ICRI_VERSION_1;
		local_icri.timeout = 15;		/* don't have to wait for this to finish */
		local_icri.record_type = IMFT_RESYNCHRONIZE;
		local_icri.record_ptr = null ();
		local_icri.record_lth, local_icri.record_max_lth = 0;
		if ds_ptr -> driver_status.dev_in_iocbp ^= null () then
		     call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "write_reply_record", addr (local_icri),
			code);
	     end;
	     call continue_to_signal_ (ignore_code);	/* let iodd_ start us over */
	end;


/* Parse the args statement which defines what this driver will be doing and how to get to the remote system */

	major_args_ptr = add_char_offset_ (addr (text_strings.chars), iodd_static.major_args.first_char - 1);
						/* use args statement value by default */
	major_args_lth = iodd_static.major_args.total_chars;

	if major_args_lth = 0 then do;
	     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "The IMFT driver requires an ""args:"" statement.");
	     go to RETURN_FROM_INIT;
	end;

	major_args_path = iodd_parse_$args ("indirect=", major_args);
						/* check for the arguments being in a file */
	if major_args_path ^= "" then do;
	     call expand_pathname_$component (major_args_path, major_args_dirname, major_args_ename,
		major_args_component, code);
	     if code ^= 0 then do;
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "^a", major_args_path);
		go to RETURN_FROM_INIT;
	     end;
	     call initiate_file_$component (major_args_dirname, major_args_ename, major_args_component, R_ACCESS,
		major_args_ptr, major_args_bc, code);
	     if code ^= 0 then do;
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "^a",
		     pathname_$component (major_args_dirname, major_args_ename, major_args_component));
		go to RETURN_FROM_INIT;
	     end;
	     major_args_lth = divide ((major_args_bc + 8), 9, 21, 0);
	     major_args_lth = length (rtrim (major_args, WHITESPACE));
	     if major_args_lth = 0 then do;
		call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "Arguments file ^a is empty.",
		     pathname_$component (major_args_dirname, major_args_ename, major_args_component));
		go to RETURN_FROM_INIT;
	     end;
	end;

	keyword_value = iodd_parse_$args ("function=", major_args);
	if (keyword_value = "") | (keyword_value = "file_transfer") then
	     static.function = FILE_TRANSFER;
	else do;
	     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "Unsupported function.  ""^a""", keyword_value);
	     go to RETURN_FROM_INIT;
	end;

	keyword_value = iodd_parse_$args ("direction=", major_args);
	if keyword_value = "" then do;		/* this is required */
	     call iodd_msg_ (ERROR, MASTER, error_table_$noarg, IMFT_DRIVER_, "Direction must be supplied.");
	     go to RETURN_FROM_INIT;
	end;
	else if keyword_value = "input" then static.input_driver = "1"b;
	else if keyword_value = "output" then static.input_driver = "0"b;
	else do;
	     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "Unsupported direction.  ""^a""", keyword_value);
	     go to RETURN_FROM_INIT;
	end;

	static.validate_system_id = "1"b;
	keyword_value = iodd_parse_$args ("validate_system_id=", major_args);
	if keyword_value ^= "" then static.validate_system_id = yes_no_p ("validate_system_id", keyword_value);

	static.local_system.name = iodd_parse_$args ("local_system=", major_args);

	if static.validate_system_id = "0"b then
	     static.local_system.password = "";
	else do;
	     if static.local_system.name ^= "" then do;
		call imft_pnt_interface_$get_system_password (static.local_system.name, static.local_system.password,
		     code);
		if code ^= 0 then do;
		     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "local_system= ^a", static.local_system.name);
		     go to RETURN_FROM_INIT;
		end;
	     end;
	     else do;
		call iodd_msg_ (ERROR, MASTER, error_table_$noarg, IMFT_DRIVER_,
		     "Local system name must be supplied.");
		go to RETURN_FROM_INIT;
	     end;
	end;

	static.foreign_system.name = iodd_parse_$args ("foreign_system=", major_args);

	if static.validate_system_id = "0"b then
	     static.foreign_system.password = "";
	else do;
	     if static.foreign_system.name ^= "" then do;
		call imft_pnt_interface_$get_system_password (static.foreign_system.name,
		     static.foreign_system.password, code);
		if code ^= 0 then do;
		     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "foreign_system= ^a",
			static.foreign_system.name);
		     go to RETURN_FROM_INIT;
		end;
	     end;
	     else do;
		call iodd_msg_ (ERROR, MASTER, error_table_$noarg, IMFT_DRIVER_,
		     "Foreign system name must be supplied.");
		go to RETURN_FROM_INIT;
	     end;
	end;

	keyword_value = iodd_parse_$args ("version=", major_args);
	if keyword_value = "" | keyword_value = CURRENT_IMFT_VERSION then do;
	     static.old_version = "0"b;
	     static.foreign_system.imft_version = CURRENT_IMFT_VERSION;
	end;
	else if keyword_value = "3.0" then do;
	     static.old_version = "0"b;
	     static.foreign_system.imft_version = "3.0";
	end;
	else if keyword_value = "2.0" then do;
	     static.old_version = "1"b;
	     static.foreign_system.imft_version = "2.0";
	end;
	else do;
	     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "Invalid version keyword: ""^a""", keyword_value);
	     go to RETURN_FROM_INIT;
	end;

	if static.old_version then
	     static.local_system.imft_version = "2.0";
	else static.local_system.imft_version = CURRENT_IMFT_VERSION;

	foreign_system_version = convert (foreign_system_version, static.foreign_system.imft_version);
%page;
/* Determine if this is an in_dial connection, and out_dial connection, or
   a normal IO connection. */

	static.in_dial_qualifier, static.out_dial_text = "";
	static.idle_line_drop = "0"b;

	static.in_dial_qualifier = iodd_parse_$args ("in_dial=", major_args);
	if static.in_dial_qualifier ^= "" then do;
	     static.single_switch = "1"b;		/* stop errors */
	     static.dial_service = "1"b;
	end;
	else do;
	     static.out_dial_text = iodd_parse_$args ("out_dial=", major_args);
	     if static.out_dial_text ^= "" then do;

/* We must dial-out to the distant system, then recognize a connection
   protocol to the dial-in channel when we get there.

   First form the dial-out io description as for a normal dial-out */

		static.dial_service = "1"b;
		static.input_attach_description = iodd_parse_$args ("io_description=", major_args);
		if static.input_attach_description = "" then
		     static.input_attach_description = iodd_parse_$args ("iods=", major_args);
		static.single_switch = (static.input_attach_description ^= "");
		static.trigger_text = iodd_parse_$args ("trigger_text=", major_args);
		if static.trigger_text = "" then do;
		     call iodd_msg_ (ERROR, MASTER, error_table_$noarg, IMFT_DRIVER_,
			"The trigger_text string must be non-null.");
		     go to RETURN_FROM_INIT;
		end;
	     end;
	end;

/* Capture dial protocol control information. */

	if static.dial_service then do;
	     keyword_value = iodd_parse_$args ("debug_connect=", major_args);
	     if keyword_value = "" then
		static.debug_connect = "0"b;
	     else static.debug_connect = yes_no_p ("debug_connect", keyword_value);

	     keyword_value = iodd_parse_$args ("idle_line_drop=", major_args);
	     if keyword_value ^= "" then do;
		if static.input_driver then do;
		     call iodd_msg_ (ERROR, MASTER, error_table_$inconsistent, IMFT_DRIVER_,
			"idle_line_drop keyword is not valid for an input driver.");
		     go to RETURN_FROM_INIT;
		end;
		static.idle_line_drop = yes_no_p ("idle_line_drop", keyword_value);

		keyword_value = iodd_parse_$args ("idle_delay_count=", major_args);
		if keyword_value = "" then
		     static.idle_delay_count = 2;	/* wait 2 idles */
		else do;
		     static.idle_delay_count = cv_dec_check_ (keyword_value, code);
		     if code ^= 0 | static.idle_delay_count < 0 | static.idle_delay_count > 1000 then do;
			call iodd_msg_ (ERROR, MASTER, error_table_$bad_conversion, "",
			     "Value of idle_delay_count must be a number between 0 and 1000; not ""^a""",
			     keyword_value);
			go to RETURN_FROM_INIT;
		     end;
		end;
		static.idle_delay = 0;
	     end;

	     keyword_value = iodd_parse_$args ("sleep_time=", major_args);
	     if keyword_value = "" then
		static.sleep_time = 5;		/* minutes */
	     else do;
		static.sleep_time = cv_dec_check_ (keyword_value, code);

		if code ^= 0 | static.sleep_time < 1 | static.sleep_time > 60 then do;
		     call iodd_msg_ (ERROR, MASTER, error_table_$bad_conversion, "",
			"Value of sleep_time must be between 1 and 60 minutes; not ""^a""", keyword_value);
		     go to RETURN_FROM_INIT;
		end;
	     end;
	end;

/* Normal connection by just doing the attachment to slave lines. */

	else do;
	     static.input_attach_description = iodd_parse_$args ("io_description=", major_args);
	     if static.input_attach_description = "" then
		static.input_attach_description = iodd_parse_$args ("iods=", major_args);
	     static.single_switch = (static.input_attach_description ^= "");
	end;

	if ^static.single_switch then do;
	     static.input_attach_description = iodd_parse_$args ("input_description=", major_args);
	     if static.input_attach_description = "" then
		static.input_attach_description = iodd_parse_$args ("ids=", major_args);
	     if static.input_attach_description = "" then do;

		call iodd_msg_ (ERROR, MASTER, error_table_$noarg, IMFT_DRIVER_, "Input attach description.");
		go to RETURN_FROM_INIT;
	     end;

	     static.output_attach_description = iodd_parse_$args ("output_description=", major_args);
	     if static.output_attach_description = "" then
		static.output_attach_description = iodd_parse_$args ("ods=", major_args);
	     if static.output_attach_description = "" then do;
		call iodd_msg_ (ERROR, MASTER, error_table_$noarg, IMFT_DRIVER_, "Output attach description.");
		go to RETURN_FROM_INIT;
	     end;
	end;

	else do;
	     if static.old_version then do;		/* can't use -io_description in pre10.2 connection" */
		call iodd_msg_ (ERROR, MASTER, error_table_$inconsistent, IMFT_DRIVER_,
		     "version=2.0 and io_description");
		go to RETURN_FROM_INIT;
	     end;

	     temp_attach_description = iodd_parse_$args ("input_description=", major_args);
	     if temp_attach_description = "" then temp_attach_description = iodd_parse_$args ("ids=", major_args);
	     if temp_attach_description ^= "" then do;
		call iodd_msg_ (ERROR, MASTER, error_table_$inconsistent, IMFT_DRIVER_,
		     "input_description and io_description");
		go to RETURN_FROM_INIT;
	     end;
	     temp_attach_description = iodd_parse_$args ("output_description=", major_args);
	     if temp_attach_description = "" then temp_attach_description = iodd_parse_$args ("ods=", major_args);
	     if temp_attach_description ^= "" then do;
		call iodd_msg_ (ERROR, MASTER, error_table_$inconsistent, IMFT_DRIVER_,
		     "output_description and io_description");
		go to RETURN_FROM_INIT;
	     end;
	end;

	local_explicit_ceiling_given = "0"b;		/* use ceiling the two systems agree upon */
	max_access_class_string = iodd_parse_$args ("max_access_class=", major_args);
	if max_access_class_string ^= "" then do;	/* explicit ceiling for data transfer */
	     local_explicit_ceiling_given = "1"b;
	     call convert_authorization_$from_string (local_explicit_ceiling, max_access_class_string, code);
	     if code ^= 0 then do;
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "^a", max_access_class_string);
		go to RETURN_FROM_INIT;
	     end;
	end;

	if ^static.old_version then do;
	     local_explicit_floor_given = "0"b;		/* use floor the two systems agree upon */
	     min_access_class_string = iodd_parse_$args ("min_access_class=", major_args);
	     if min_access_class_string ^= "" then do;	/* explicit floor for data transfer */
		local_explicit_floor_given = "1"b;
		call convert_authorization_$from_string (local_explicit_floor, min_access_class_string, code);
		if code ^= 0 then do;
		     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "^a", min_access_class_string);
		     go to RETURN_FROM_INIT;
		end;
	     end;

	     if local_explicit_ceiling_given & local_explicit_floor_given then
		if ^aim_check_$greater_or_equal (local_explicit_ceiling, local_explicit_floor) then do;
		     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
			"max_access_class (""^a"") is not greater than or equal to min_access_class (""^a"")",
			max_access_class_string, min_access_class_string);
		     go to RETURN_FROM_INIT;
		end;
	end;

	keyword_value = iodd_parse_$args ("mode=", major_args);
	if (keyword_value = "") | (keyword_value = "manual") then do;
	     static.automatic_operation = "0"b;		/* manual mode: operator intervention required */
	     static.auto_receive, static.auto_go = "0"b;	/* whichever is appropriate defaults to no */
	end;
	else if (keyword_value = "automatic") | (keyword_value = "auto") then do;
	     static.automatic_operation = "1"b;		/* automatic mode: keep running without intervention */
	     static.auto_receive, static.auto_go = "1"b;	/* whichever is appropriate defaults to yes */
	end;
	else do;
	     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "Unsupported operational mode.  ""^a""", keyword_value);
	     go to RETURN_FROM_INIT;
	end;

	keyword_value = iodd_parse_$args ("allow_remote_request=", major_args);
	if keyword_value ^= "" then do;
	     if ^static.input_driver then do;
		call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
		     "The ""allow_remote_request"" keyword may not be specified for an output driver.");
		go to RETURN_FROM_INIT;
	     end;

	     if yes_no_p ("allow_remote_request", keyword_value) then do;
						/* said we could accept remote requests */
		if static.old_version		/* not with an old other end, we can't */
		then do;
		     call iodd_msg_ (ERROR, MASTER, error_table_$inconsistent, IMFT_DRIVER_,
			"Remote requests cannot be allowed if version=2.0.");
		     go to RETURN_FROM_INIT;
		end;

		static.remote_request_allowed = "1"b;

		keyword_value = iodd_parse_$args ("explicit_access=", major_args);
		if keyword_value = ""		/* this one defaults to "yes" */
		     then
		     static.explicit_access_required = "1"b;
		else static.explicit_access_required = yes_no_p ("explicit_access", keyword_value);
	     end;

	     else static.remote_request_allowed = "0"b;
	end;

	else static.remote_request_allowed = "0"b;

	keyword_value = iodd_parse_$args ("auto_receive=", major_args);
	if keyword_value ^= "" then
	     if static.input_driver then		/* only valid for input drivers */
		static.auto_receive = yes_no_p ("auto_receive", keyword_value);
	     else do;
		call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
		     "The ""auto_receive"" keyword may not be specified for an output driver.");
		go to RETURN_FROM_INIT;
	     end;

	keyword_value = iodd_parse_$args ("auto_go=", major_args);
	if keyword_value ^= "" then
	     if ^static.input_driver then		/* only valid for output drivers */
		static.auto_go = yes_no_p ("auto_go", keyword_value);
	     else do;
		call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
		     "The ""auto_go"" keyword may not be specified for an input driver.");
		go to RETURN_FROM_INIT;
	     end;

	keyword_value = iodd_parse_$args ("min_time_est_msg=", major_args);
	if keyword_value = "" then
	     static.min_time_to_log = 60;		/* seconds */
	else do;
	     static.min_time_to_log = cv_dec_check_ (keyword_value, code);

	     if code ^= 0 | static.min_time_to_log < 30 | static.min_time_to_log > 3600 then do;
		call iodd_msg_ (ERROR, MASTER, error_table_$bad_conversion, IMFT_DRIVER_,
		     "Value of min_time_est_msg must be a number between 30 and 3600 seconds, not ""^a""",
		     keyword_value);
		go to RETURN_FROM_INIT;
	     end;
	end;

	static.debug_mode, static.copy_data = "0"b;	/* defaults to not debugging, of course */
	if iodd_static.test_entry then do;		/* recognize debug_mode when running in test mode */
	     keyword_value = iodd_parse_$args ("debug_mode=", major_args);
	     if keyword_value ^= "" then static.debug_mode = yes_no_p ("debug_mode", keyword_value);

	     keyword_value = iodd_parse_$args ("copy_data=", major_args);
	     if keyword_value ^= "" then static.copy_data = yes_no_p ("copy_data", keyword_value);

	end;

	iodd_static.test_entry = static.debug_mode;	/* if not in debug_mode, disable all debugging facilities
						   and allow the driver to run a "real" service */

/* Function specific args statement processing goes here */

	on condition (linkage_error)
	     begin;
	     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
		"Driver process lacks access to the system_privilege_ gate.");
	     go to RETURN_FROM_INIT;
	end;

	test_initiate_entry = system_privilege_$initiate; /* check that we can get appropriate privileges */

	revert condition (linkage_error);

	call attach_and_init_line;

	if ^static.input_driver then on condition (daemon_idle) call check_for_resync_request ();

/* Synchronize operations with the remote system: control will also arrive
   here whenever the remote system requests explicit resynchronization */

RESYNCHRONIZE_DRIVER:				/* Ensure that we are properly attached. */
	if ds_ptr -> driver_status.dev_in_iocbp = null () then call attach_and_init_line;

	iodd_static.master_hold = "1"b;		/* wait for commands from the master console by default */
	iodd_static.slave_hold = "0"b;		/* actually, there is no slave terminal, but ... */

	call resynch_and_validate;

	if static.input_driver then			/* input device ... */
	     if static.auto_receive then do;		/* ... start receiving immediately */
		on condition (quit) call iodd_quit_handler_ ();
		on condition (resume) go to PREPARE_TO_CALL_IODD_LISTEN_;
		call iodd_msg_ (NORMAL, MASTER, 0, "", "Waiting for ^[files/subtrees^] from ^a.", static.function,
		     static.foreign_system.name);
		if static.function = FILE_TRANSFER then
		     call imft_receive_object_ (addr (static), addr (static_fis_info), code);
		if code ^= 0 then do;		/* error has already been reported */
		     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
			"Fatal error during ""receive"" command; driver will re-initialize.");
		     call detach_device ();		/* just in case */
		     signal condition (re_init);
		end;
PREPARE_TO_CALL_IODD_LISTEN_:				/* release command from a quit will arrive here */
		revert condition (quit), condition (resume);
	     end;
	     else ;				/* go directly to the command loop */

	else do;					/* output device ... */
	     if static.auto_go then do;		/* ... start processing immediately if requested */
		do i = 1 to iodd_static.assigned_devices;
		     devp = driver_ptr_list.stat_segp (i);
		     call iodd_command_processor_ (MASTER, LISTEN_COMMAND_LEVEL,
			"restart_q " || devp -> driver_status.device_id, ignore_code);
		end;
		iodd_static.master_hold = "0"b;
	     end;
	end;

	call iodd_listen_ (stat_p);			/* start the driver operating */


/* Control arrives here iff initialization fails */

RETURN_FROM_INIT:
	iodd_static.test_entry = saved_test_entry;
	if (major_args_ptr ^= null ())
	     & (major_args_ptr ^= add_char_offset_ (addr (text_strings.chars), iodd_static.major_args.first_char - 1))
	     then
	     call terminate_file_ (major_args_ptr, 0, TERM_FILE_TERM, ignore_code);
	call drop_device ();
	call free_aim_attributes_storage;
	return;


/* Control arrives here if a logout is received from the slave (this won't happen, but...) */

LOGOUT_SLAVE:
	iodd_static.re_init_in_progress = "1"b;		/* re-initialize the driver */
	iodd_static.slave.log_msg = "1"b;		/* send to log and slave */
	call iodd_msg_ (LOG, BOTH, 0, "", "Logout for ^a ^a ^[input^;output^] driver at ^a.",
	     static.foreign_system.name, FUNCTION_NAMES (static.function), static.input_driver,
	     date_time_$format ("date_time", clock (), "", ""));
	call iox_$control (iodd_static.slave_out, "runout", null (), ignore_code);
	call drop_device ();
	call iodd_msg_ (NORMAL, MASTER, 0, "", "Driver starting re-initialization...");
	go to iodd_static.re_init_label;		/* this will do everything */
%page;
/* Entry to attach the line and initialize driver_status information. */

attach_and_init_line:
     proc;
	if static.input_driver then do;

/* An input driver: requests are not processed from the coordinator; this driver is controlled by the remote system's
   output driver */

	     if iodd_static.assigned_devices > 1 then do; /* only one device per input driver */
		call iodd_msg_ (ERROR, MASTER, error_table_$fatal_error, IMFT_DRIVER_,
		     "The IMFT driver only supports one minor device for an input driver.");
		return;
	     end;

	     call validate_request_type (ds_ptr);
	     ds_ptr -> driver_status.attached = "0"b;	/* do not accept anything from coordinator */

	     call iodd_msg_ (NORMAL, MASTER, 0, "", "^/Initializing ^a ^a input driver...", static.foreign_system.name,
		FUNCTION_NAMES (static.function));

	     call attach_line ();

	     call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "read_status", addr (trsi), code);
	     if code ^= 0 then do;
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Can not determine when input is available.");
		go to RETURN_FROM_INIT;
	     end;

	     static_fis_info.version = FIS_INFO_VERSION_1;
	     static_fis_info.n_iocbs, static_fis_info.n_channels = 2;
	     static_fis_info.iocbs (1) = iodd_static.master_in;
	     static_fis_info.event_channels (1) = iodd_static.chan_list_ptr -> event_channel_list.channels (1);
	     static_fis_info.iocbs (2) = ds_ptr -> driver_status.dev_in_iocbp;
	     static_fis_info.event_channels (2) = trsi.event_channel;
	end;


	else do;

/* Transmitting to foreign Multics system: process requests from the coordinator */

	     list_ptr = iodd_static.driver_list_ptr;
	     do i = 1 to iodd_static.assigned_devices;	/* check request types for minor device(s) */
						/* doesn't return if an error occurs */
		call validate_request_type (driver_ptr_list.stat_segp (i));
	     end;

	     call iodd_msg_ (NORMAL, MASTER, 0, "", "^/Initializing ^a ^a output driver...", static.foreign_system.name,
		FUNCTION_NAMES (static.function));

	     if static.function = FILE_TRANSFER then do;	/* expect use of enter_imft_request */
		ds_ptr -> driver_status.generic_type = FT_GENERIC_TYPE;
		ds_ptr -> driver_status.message_type = FT_MESSAGE_TYPE;
	     end;

	     if ds_ptr -> driver_status.rqti_ptr ^= null () then
		call iodd_msg_ (NORMAL, MASTER, 0, IMFT_DRIVER_, "This driver cannot decode an RQTI segment.");

	     call attach_line ();

	     ds_ptr -> driver_status.attached = "1"b;

	     ds_ptr -> driver_status.elem_size = 9;

	     ds_ptr -> driver_status.ready = "1"b;	/* mark as ready to save an operator command */

	     local_terminal_info.version = terminal_info_version;
	     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "terminal_info", addr (local_terminal_info),
		code);
	     if code = 0 then
		ds_ptr -> driver_status.bit_rate_est = divide (local_terminal_info.baud_rate * 2, 3, 35, 0);
	     else ds_ptr -> driver_status.bit_rate_est = INITIAL_IMFT_RATE;

	     if iodd_static.assigned_devices = 2 then do; /* copy necessary stuff to second minor device's */
		devp = driver_ptr_list.stat_segp (2);	/* status structure */
		devp -> driver_status.attached = "1"b;
		devp -> driver_status.ready = "1"b;
		devp -> driver_status.dev_out_iocbp = ds_ptr -> driver_status.dev_out_iocbp;
		devp -> driver_status.dev_in_iocbp = ds_ptr -> driver_status.dev_in_iocbp;
		devp -> driver_status.dev_out_stream = ds_ptr -> driver_status.dev_out_stream;
		devp -> driver_status.dev_in_stream = ds_ptr -> driver_status.dev_in_stream;
		devp -> driver_status.elem_size = ds_ptr -> driver_status.elem_size;
		devp -> driver_status.message_type = ds_ptr -> driver_status.message_type;
		devp -> driver_status.bit_rate_est = ds_ptr -> driver_status.bit_rate_est;
		devp -> driver_status.generic_type = ds_ptr -> driver_status.generic_type;
		devp -> driver_status.dev_ctl_ptr = null ();
		devp -> driver_status.defer_time_limit = 0;
	     end;
	end;
     end attach_and_init_line;
%page;
/* Procedure to validate the IMFT synchronization and aim levels. */

resynch_and_validate:
     proc;
	if static.input_driver then do;		/* the actual code is fairly complex ... */
	     call synchronize_input_driver ();
	     call establish_input_access_ceiling ();
	end;

	else do;					/* ... so it's not shown here */
	     call synchronize_output_driver ();
	     call establish_output_access_ceiling ();
	end;


/* Synchronization completed: start things running ... */

	call convert_authorization_$to_string_short (static.local_system.access_ceiling, max_access_class_string, code);
	if code ^= 0 then do;			/* can't convert it: use octal representation */
	     call convert_aim_attributes_ (static.local_system.access_ceiling, max_access_class_octal);
	     max_access_class_string = max_access_class_octal;
	end;

	if ^static.old_version then do;
	     call convert_authorization_$to_string_short (static.local_system.access_floor, min_access_class_string,
		code);
	     if code ^= 0 then do;			/* can't convert it: use octal representation */
		call convert_aim_attributes_ (static.local_system.access_floor, min_access_class_octal);
		min_access_class_string = min_access_class_octal;
	     end;
	end;
	else min_access_class_string = "";

	call iodd_msg_ (NORMAL, MASTER, 0, "",
	     "^a ^a ^[input^;output^] driver (version ^a) ready at ^a^/^[^3xusing channel ^a for input^[/^s^;, channel ^a for ^]output, and^/^3x^;^s^s^s^3xusing ^]^[^a^;^ssystem_low^]:^[^a^;^ssystem_low^] as the allowable range of access classes for data transfer.",
	     static.foreign_system.name, FUNCTION_NAMES (static.function), static.input_driver,
	     static.local_system.imft_version, date_time_$format ("date_time", clock (), "", ""), have_channel_names,
	     local_gcn.input_channel, static.single_switch, local_gcn.output_channel, (min_access_class_string ^= ""),
	     min_access_class_string, (max_access_class_string ^= ""), max_access_class_string);
     end resynch_and_validate;
%page;
/* Process request:  Invoked by iodd_listen_ when a request has been received
   from the coordinator for transmission to the remote system.  Validate the
   request format and then pass it off to the appropriate module */

request:
     entry ();

dcl  driver_ptr ptr static;

	driver_ptr = iodd_static.driver_ptr;
	if driver_ptr -> driver_status.dev_out_iocbp = null () then do;
	     call iodd_msg_ (NORMAL, MASTER, 0, "", "Driver waking up to start re-initialization...");
	     call attach_and_init_line;		/* restablish link */
	     call resynch_and_validate;
	end;

	static.idle_delay = 0;			/* reset counter */
	rd_ptr = addr (driver_ptr -> driver_status.descriptor);
						/* ... the request descriptor ... */

	p = addr (driver_ptr -> driver_status.message);	/* ... and the request itself */

	if p -> queue_msg_hdr.hdr_version ^= queue_msg_hdr_version_1 then do;
	     call iodd_msg_ (LOG, MASTER, 0, "", "Invalid message header.  Cannot read request ^d (queue ^d).",
		rd_ptr -> request_descriptor.seq_id, rd_ptr -> request_descriptor.q);
	     rd_ptr -> request_descriptor.keep_in_queue = "1"b;
	     rd_ptr -> request_descriptor.dont_delete = "1"b;
	     rd_ptr -> request_descriptor.finished = "1"b;
	     return;				/* leave in queue for possible upgrade later ... */
	end;					/* ... and give it back to the coordinator */

	if p -> queue_msg_hdr.message_type ^= driver_ptr -> driver_status.message_type then do;
	     call iodd_msg_ (LOG, MASTER, 0, "",
		"Incorrect message type.^/Request ^d (queue ^d) for ^a (entry ^a) not processed.",
		rd_ptr -> request_descriptor.seq_id, rd_ptr -> request_descriptor.q,
		rd_ptr -> request_descriptor.sender_id, p -> queue_msg_hdr.ename);
	     rd_ptr -> request_descriptor.cancelled = "1"b;
	     rd_ptr -> request_descriptor.dont_delete = "1"b;
	     rd_ptr -> request_descriptor.finished = "1"b;
	     return;				/* give up: it won't ever work ... */
	end;					/* ... but don't get rid of the object */

	if static.function = FILE_TRANSFER then
	     if p -> ft_request.version ^= FT_REQUEST_VERSION_1 then do;
		call iodd_msg_ (LOG, MASTER, 0, "",
		     "Wrong message version found.^/Request ^d (queue ^d) for ^a (entry ^a) not processed.",
		     rd_ptr -> request_descriptor.seq_id, rd_ptr -> request_descriptor.q,
		     rd_ptr -> request_descriptor.sender_id, p -> queue_msg_hdr.ename);
		rd_ptr -> request_descriptor.keep_in_queue = "1"b;
		rd_ptr -> request_descriptor.dont_delete = "1"b;
		rd_ptr -> request_descriptor.finished = "1"b;
		return;				/* leave it around to be upgraded later */
	     end;
	     else ;				/* request is proper version */


/* Format is OK: do the request */

	iodd_static.quit_during_request = "0"b;

	on condition (cleanup)
	     call iox_$control (driver_ptr -> driver_status.dev_out_iocbp, "runout", null (), ignore_code);

	if static.function = FILE_TRANSFER then
	     call imft_transmit_object_ (driver_ptr -> driver_status.dev_out_iocbp, stat_p, addr (static), code);

	if code ^= 0 then do;			/* error has already been reported */
	     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
		"Fatal error during processing of the request; driver will re-initialize.");
	     signal condition (re_init);
	end;

	call iox_$control (driver_ptr -> driver_status.dev_out_iocbp, "runout", null (), ignore_code);

	if static_pause_time > 1 then call timer_manager_$sleep (static_pause_time, RELATIVE_SECONDS);

	return;
%page;
/* Process a driver command */

command:
     entry (P_source, P_state, P_arglist_ptr, P_code);

	source = P_source;
	arglist_ptr = P_arglist_ptr;			/* structure containing command arguments */

	saved_code = P_code;			/* save input code in case command is unknown */

	P_code, code = 0;				/* claim to handle it */

/* Process the command if recognized */

	if (arglist.command = "help") then do;
	     call iodd_msg_ (NORMAL, source, 0, "", "^/** Commands for the IMFT driver **^/");
	     if static.input_driver then		/* an input driver */
		call iodd_msg_ (NORMAL, source, 0, "", "receive");
	     else do;
		call iodd_msg_ (NORMAL, source, 0, "", "pause_time [<seconds_to_delay_between_requests>]");
		call iodd_msg_ (NORMAL, source, 0, "", "line_speed");
	     end;
	end;

	else if (arglist.command = "pause_time") | (arglist.command = "pausetime") then do;
	     if static.input_driver then do;		/* only for output drivers */
		call iodd_msg_ (NORMAL, source, 0, "", "Invalid command for an input driver.");
		go to COMMAND_ERROR;
	     end;
	     if (arglist.n_tokens > 1) then do;		/* a specific time is given */
		value = cv_dec_check_ ((arglist.arguments (1)), code);
		if (code ^= 0) then do;
BAD_PAUSE_TIME_SPECIFICATION:
		     call iodd_msg_ (NORMAL, source, error_table_$bad_conversion, "",
			"Pause time specification must be a number between 0 and 30 seconds; not ""^a"".",
			arglist.arguments (1));
		     go to COMMAND_ERROR;
		end;
		if (value < 0) | (value > 30) then go to BAD_PAUSE_TIME_SPECIFICATION;
		static_pause_time = value;		/* good value */
	     end;
	     else static_pause_time = 10;		/* reset to default value */
	end;

	else if (arglist.command = "receive") then do;
	     if ^static.input_driver then do;		/* only valid for input drivers */
		call iodd_msg_ (NORMAL, source, 0, "", "Invalid command for an output driver.");
		go to COMMAND_ERROR;
	     end;

/* Ensure that we are properly attached. */

	     if ds_ptr -> driver_status.dev_in_iocbp = null () then do;
		call attach_and_init_line;		/* restablish link */
		call resynch_and_validate;
	     end;

	     call iodd_msg_ (NORMAL, MASTER, 0, "", "Waiting for ^[files/subtrees^] from ^a.", static.function,
		static.foreign_system.name);
	     if static.function = FILE_TRANSFER then
		call imft_receive_object_ (addr (static), addr (static_fis_info), code);
	     if code ^= 0 then do;			/* error has already been reported */
		call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
		     "Fatal error during ""receive"" command; driver will re-initialize.");
		signal condition (re_init);
	     end;
	end;

	else if (arglist.command = "line_speed") | (arglist.command = "linespeed") then do;
	     if static.input_driver then do;		/* only for output drivers */
		call iodd_msg_ (NORMAL, source, 0, "", "Invalid command for an input driver.");
		go to COMMAND_ERROR;
	     end;
	     call iodd_msg_ (NORMAL, source, 0, "", "line_speed = ^i Baud.", ds_ptr -> driver_status.bit_rate_est);
	end;

	else code = saved_code;			/* unknown request: let caller handle it */

	P_code = code;				/* pass back any defined errors */
	return;

COMMAND_ERROR:
	P_code = error_table_$action_not_performed;	/* cause a resetread */
	return;
%page;
/* Handler for unexpected conditions during request processing */

default_handler:
     entry (P_condition_info_ptr);

	condition_info_ptr = P_condition_info_ptr;

	condition = condition_info.condition_name;

	if iodd_static.request_in_progress then		/* will abort the request */
	     if static.function = FILE_TRANSFER then call imft_transmit_object_$abort_running_request (condition);

	return;					/* should not get here */
%page;
/* Synchronize an input driver: Wait for a SYNC1 command from the remote system.  When it arrives, validate the
   ID/password in the command against the foreign ID/password specified locally.  If they match, send a SYNC1 reply
   containing our ID/password to the remote system and wait for a SYNC2 command; otherwise, send a SYNC1 reply explaining
   the problem and abort.  When the SYNC2 command arrives, send a SYNC2 reply if the command indicates that
   synchronization suceeded; otherwise, abort */

synchronize_input_driver:
     procedure ();

	call read_sync_command (IMFT_SYNC1);

	sync_record_ptr = addr (input_buffer);
	if static.foreign_system.name ^= sync_record.my_userid then do;
	     call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_ids, IMFT_DRIVER_,
		"ID specified on local system is ^a; ID specified on remote system is ^a.",
		static.foreign_system.name, sync_record.my_userid);
	     call write_sync_reply (IMFT_SYNC1, "", "", imft_et_$non_matching_ids, static.foreign_system.name);
	     go to RETURN_FROM_INIT;
	end;

	if static.foreign_system.password ^= sync_record.my_password then do;
	     call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_passwords, IMFT_DRIVER_,
		"Validating foreign system ID.  ""^a""", sync_record.my_userid);
	     call write_sync_reply (IMFT_SYNC1, "", "", imft_et_$non_matching_passwords, "");
	     go to RETURN_FROM_INIT;
	end;

	if local_icri.record_lth ^= 4 * currentsize (sync_record) then do;
						/* remote driver is pre 4.0 */
	     if foreign_system_version >= 4.0 then do;
		call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_versions, IMFT_DRIVER_,
		     "Remote system appears to be pre 4.0 but was specified to be ^a on local system.",
		     static.foreign_system.imft_version);
		call write_sync_reply (IMFT_SYNC1, "", "", imft_et_$non_matching_versions, "");
		go to RETURN_FROM_INIT;
	     end;
	end;

	else if static.foreign_system.imft_version ^= sync_record.imft_version then do;
	     call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_versions, IMFT_DRIVER_,
		"Remote system claims to be ""^a"" but specified locally to be ""^a"".", sync_record.imft_version,
		static.foreign_system.imft_version);
	     call write_sync_reply (IMFT_SYNC1, "", "", imft_et_$non_matching_versions, "");
	     go to RETURN_FROM_INIT;
	end;

/* Here iff the ID/password in the SYNC1 command were acceptable */

	call write_sync_reply (IMFT_SYNC1, static.local_system.name, static.local_system.password, 0, "");

	call read_sync_command (IMFT_SYNC2);

	sync_record_ptr = addr (input_buffer);
	if sync_record.code = 0 then			/* remote system accepted our ID/password */
	     call write_sync_reply (IMFT_SYNC2, "", "", 0, "");

	else do;					/* remote output driver didn't like our ID/password */
	     code = imft_convert_status_code_$decode (sync_record.code);
	     if code = imft_et_$non_matching_ids then
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_,
		     "ID specified on local system is ^a; ID specified on remote system is ^a.",
		     static.local_system.name, sync_record.correct_userid);
	     else call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Validating local system ID.  ""^a""",
		     static.local_system.name);
	     go to RETURN_FROM_INIT;
	end;

	return;					/* here iff synchronized OK */
%page;
/* Internal to synchronize_input_driver: attempts to transmit a SYNC reply */

write_sync_reply:
	procedure (p_sync_type, p_my_userid, p_my_password, p_code, p_correct_userid);

dcl  p_sync_type fixed binary (7) unaligned unsigned parameter;
dcl  (p_my_userid, p_correct_userid) character (*) parameter;
dcl  p_my_password character (8) aligned parameter;
dcl  p_code fixed binary (35) parameter;

dcl  code fixed binary (35);

	     sync_record_ptr = addr (output_buffer);	/* need a place to put it */
	     sync_record.my_userid = p_my_userid;
	     sync_record.my_password = p_my_password;
	     sync_record.code = imft_convert_status_code_$encode (p_code);
	     sync_record.correct_userid = p_correct_userid;
	     sync_record.imft_version = CURRENT_IMFT_VERSION;

	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = FIVE_MINUTES;		/* give the other side a chance to respond */
	     local_icri.record_type = p_sync_type;
	     local_icri.record_ptr = sync_record_ptr;
	     local_icri.record_lth = 4 * currentsize (sync_record);

	     call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "write_reply_record", addr (local_icri), code);

	     if code ^= 0 then do;			/* any I/O errors are fatal */
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to synchronize with ^a.",
		     static.foreign_system.name);
		go to RETURN_FROM_INIT;
	     end;

	     return;				/* success */

	end write_sync_reply;



/* Internal to synchronize_input_driver: attempts to read a SYNC command */

read_sync_command:
	procedure (p_sync_type);

dcl  p_sync_type fixed binary (7) unaligned unsigned parameter;

	     local_icri.version = ICRI_VERSION_1;
	     if static.automatic_operation & (p_sync_type = IMFT_SYNC1) then
		local_icri.timeout = 0;		/* wait forever for start of synchronization sequence */
	     else local_icri.timeout = FIVE_MINUTES;
	     local_icri.record_ptr = addr (input_buffer);
	     local_icri.record_max_lth = length (input_buffer);

	     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "read_command_record", addr (local_icri), code);

	     if code = 0 then			/* got something ... */
		if local_icri.record_type = p_sync_type then
		     return;			/* ... got the right type of command */

		else do;				/* ... anything else causes us to try over again */
		     call write_sync_reply (IMFT_RESYNCHRONIZE, "", "", 0, "");
		     go to RESYNCHRONIZE_DRIVER;
		end;

	     else do;				/* some more serious error */
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to synchronize with ^a.",
		     static.foreign_system.name);
		go to RETURN_FROM_INIT;
	     end;

	end read_sync_command;

     end synchronize_input_driver;
%page;
/* Establish the AIM access class ceiling for an input driver: Wait for the AIM1 command giving the source system's AIM
   attributes definition and then transmit an AIM1 reply consisting of our attributes.  Wait for the AIM2 command which
   contains the source system's computed access ceiling and explicit ceiling (if any); verify that they match the local
   values and that the local explicit ceiling is less than or equal to the computed ceiling.  If all goes well, send an
   AIM2 reply with a zero code; otherwise, send a non-zero reply code and abort */

establish_input_access_ceiling:
     procedure ();

dcl  1 local_aim2_record aligned like aim2_record;


	call read_aim_command (IMFT_AIM1);		/* aborts if we can't get it */

	if addr (input_buffer) -> aim_attributes.version ^= AIM_ATTRIBUTES_VERSION_1 then do;
	     call iodd_msg_ (ERROR, MASTER, error_table_$unimplemented_version, IMFT_DRIVER_,
		"Can not understand AIM definition from ^a.", static.foreign_system.name);
	     go to RETURN_FROM_INIT;			/* ... other side will timeout */
	end;

	call free_aim_attributes_storage;

	allocate aim_attributes in (system_area) set (static.foreign_system.aim_attributes_ptr);
	static.foreign_system.aim_attributes_ptr -> aim_attributes = addr (input_buffer) -> aim_attributes;

	call get_system_aim_attributes_ (get_system_free_area_ (), AIM_ATTRIBUTES_VERSION_1,
	     static.local_system.aim_attributes_ptr, code);
	if code ^= 0 then do;			/* shouldn't get this but... */
	     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to get local AIM definition.");
	     go to RETURN_FROM_INIT;			/* ... other side will timeout */
	end;

	call write_aim_reply (IMFT_AIM1, static.local_system.aim_attributes_ptr,
	     (4 * currentsize (static.local_system.aim_attributes_ptr -> aim_attributes)));


/* Have exchanged AIM definitions: wait for AIM2 command and validate other system's computed ceiling and explicit ceiling
   against our own */

	call read_aim_command (IMFT_AIM2);

	if static.old_version then do;		/* we read old, shorter form of AIM2 record */
	     aim2_record_ptr = addr (local_aim2_record);
	     aim2_record = addr (input_buffer) -> v2_aim2_record, by name;
	end;

	else aim2_record_ptr = addr (input_buffer);

	if aim2_record.code ^= 0 then do;		/* remote system couldn't compute definition */
	     code = imft_convert_status_code_$decode (aim2_record.code);
	     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.",
		static.foreign_system.name);
	     go to RETURN_FROM_INIT;
	end;

	call compute_common_aim_ceiling_ (static.local_system.aim_attributes_ptr, static.local_system.access_ceiling,
	     static.foreign_system.aim_attributes_ptr, static.foreign_system.access_ceiling, code);
	if code ^= 0 then do;
CANT_ESTABLISH_CEILING:
	     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.",
		static.foreign_system.name);
	     call write_aim2_reply (code);		/* let remote system know we lost */
	     go to RETURN_FROM_INIT;
	end;

	if ^aim_check_$equal (aim2_record.computed_ceiling, static.foreign_system.access_ceiling) then do;
	     call iodd_msg_ (ERROR, MASTER, imft_et_$computed_ceiling_mismatch, IMFT_DRIVER_,
		"Attempting to establish access ceiling with ^a.", static.foreign_system.name);
	     call write_aim2_reply (imft_et_$computed_ceiling_mismatch);
	     go to RETURN_FROM_INIT;
	end;

	if local_explicit_ceiling_given | aim2_record.explicit_ceiling_given then do;
	     if ^local_explicit_ceiling_given then local_explicit_ceiling = static.local_system.access_ceiling;

	     if aim2_record.explicit_ceiling_given then do;
		call translate_aim_attributes_ (static.foreign_system.aim_attributes_ptr,
		     aim2_record.explicit_ceiling, static.local_system.aim_attributes_ptr, foreign_explicit_ceiling,
		     code);
		if code ^= 0 then go to CANT_ESTABLISH_CEILING;
	     end;
	     else foreign_explicit_ceiling = static.local_system.access_ceiling;

	     if aim_check_$greater_or_equal (local_explicit_ceiling, foreign_explicit_ceiling)
						/* other side wants lower ceiling than we had specified */
		then
		static.local_system.access_ceiling = foreign_explicit_ceiling;

	     else if aim_check_$greater (foreign_explicit_ceiling, local_explicit_ceiling) then do;
		static.local_system.access_ceiling = local_explicit_ceiling;
						/* our ceiling controls */
		call translate_aim_attributes_ (static.local_system.aim_attributes_ptr,
		     static.local_system.access_ceiling, static.foreign_system.aim_attributes_ptr,
		     static.foreign_system.access_ceiling, code);
						/* so we have to translate it for the other system */
		if code ^= 0 then go to CANT_ESTABLISH_CEILING;
	     end;

	     else do;				/* neither one is >= the other, so they must be isolated */
		call iodd_msg_ (ERROR, MASTER, imft_et_$explicit_ceiling_mismatch, IMFT_DRIVER_,
		     "Attempting to establish access ceiling with ^a.", static.foreign_system.name);
		call write_aim2_reply (imft_et_$explicit_ceiling_mismatch);
		go to RETURN_FROM_INIT;
	     end;
	end;

	if ^static.old_version then do;
	     if local_explicit_floor_given | aim2_record.explicit_floor_given then do;
		if ^local_explicit_floor_given then local_explicit_floor = ""b;

		if aim2_record.explicit_floor_given then do;
		     call translate_aim_attributes_ (static.foreign_system.aim_attributes_ptr,
			aim2_record.explicit_floor, static.local_system.aim_attributes_ptr, foreign_explicit_floor,
			code);
		     if code ^= 0 then go to CANT_ESTABLISH_CEILING;
		end;
		else foreign_explicit_floor = ""b;

		if aim_check_$greater_or_equal (foreign_explicit_floor, local_explicit_floor)
						/* other side wants higher floor than we had specified */
		     then
		     static.local_system.access_floor = foreign_explicit_floor;

		else if aim_check_$greater (local_explicit_floor, foreign_explicit_floor) then do;
		     static.local_system.access_floor = local_explicit_floor;
						/* our floor controls */
		     call translate_aim_attributes_ (static.local_system.aim_attributes_ptr,
			static.local_system.access_floor, static.foreign_system.aim_attributes_ptr,
			static.foreign_system.access_floor, code);
						/* so we have to translate it for the other system */
		     if code ^= 0 then go to CANT_ESTABLISH_CEILING;
		end;

		else do;				/* neither one is >= the other, so they must be isolated */
		     call iodd_msg_ (ERROR, MASTER, imft_et_$explicit_floor_mismatch, IMFT_DRIVER_,
			"Attempting to establish access floor with ^a.", static.foreign_system.name);
		     call write_aim2_reply (imft_et_$explicit_floor_mismatch);
		     go to RETURN_FROM_INIT;
		end;
	     end;
	     else static.local_system.access_floor, static.foreign_system.access_floor = ""b;
						/* no explicit floors, use system low for both */

	     if ^aim_check_$greater_or_equal (static.local_system.access_ceiling, static.local_system.access_floor)
						/* make sure the resulting range is non-null */
	     then do;
		call convert_authorization_$to_string_short (static.local_system.access_ceiling,
		     max_access_class_string, code);
		if code ^= 0 then do;
		     call convert_aim_attributes_ (static.local_system.access_ceiling, max_access_class_octal);
		     max_access_class_string = max_access_class_octal;
		end;

		call convert_authorization_$to_string_short (static.local_system.access_floor,
		     min_access_class_string, code);
		if code ^= 0 then do;
		     call convert_aim_attributes_ (static.local_system.access_floor, min_access_class_octal);
		     min_access_class_string = min_access_class_octal;
		end;

		call iodd_msg_ (ERROR, MASTER, error_table_$ai_outside_common_range, IMFT_DRIVER_,
		     "Computed access ceiling (^[^a^;^ssystem_low^]) is not greater than or equal to computed access floor (^[^a^;^ssystem_low^]).",
		     (max_access_class_string ^= ""), max_access_class_string, (min_access_class_string ^= ""),
		     min_access_class_string);
		call write_aim2_reply (error_table_$ai_outside_common_range);
		go to RETURN_FROM_INIT;
	     end;
	end;

	if ^aim_check_$greater_or_equal (get_authorization_ (), static.local_system.access_ceiling) then do;
	     call convert_authorization_$to_string_short (static.local_system.access_ceiling, max_access_class_string,
		code);
	     if code ^= 0 then do;
		call convert_aim_attributes_ (static.local_system.access_ceiling, max_access_class_octal);
		max_access_class_string = max_access_class_octal;
	     end;
	     call iodd_msg_ (ERROR, MASTER, imft_et_$process_authorization_too_low, IMFT_DRIVER_,
		"Minimum process authorization must be ^[^a^;^ssystem_low^].", (max_access_class_string ^= ""),
		max_access_class_string);
	     call write_aim2_reply (imft_et_$process_authorization_too_low);
	     go to RETURN_FROM_INIT;
	end;


/* Here iff AIM ceiling is computed and OK */

	call write_aim2_reply (NO_ERROR);

	return;
%page;
/* Internal to establish_input_access_ceiling: attempts to transmit an AIM reply */

write_aim_reply:
	procedure (p_aim_type, p_record_ptr, p_record_lth);

dcl  p_aim_type fixed binary (7) unaligned unsigned parameter;
dcl  p_record_ptr pointer parameter;
dcl  p_record_lth fixed binary (21) parameter;
dcl  code fixed binary (35);

	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = FIVE_MINUTES;		/* give the other side a chance */
	     local_icri.record_type = p_aim_type;
	     local_icri.record_ptr = p_record_ptr;
	     local_icri.record_lth = p_record_lth;

	     call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "write_reply_record", addr (local_icri), code);

	     if code ^= 0 then do;			/* any I/O error is fatal */
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.",
		     static.foreign_system.name);
		go to RETURN_FROM_INIT;
	     end;

	     return;

	end write_aim_reply;



/*  Internal to establish_input_access_ceiling: attempts to transmit an AIM2 reply */

write_aim2_reply:
	procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	     aim2_record_ptr = addr (output_buffer);	/* need a place to put it */
	     aim2_record.code = imft_convert_status_code_$encode (p_code);

	     if static.old_version then
		call write_aim_reply (IMFT_AIM2, aim2_record_ptr, (4 * currentsize (v2_aim2_record)));

	     else do;
		if aim2_record.code = 0 then do;
		     aim2_record.computed_ceiling = static.local_system.access_ceiling;
		     aim2_record.computed_floor = static.local_system.access_floor;
		end;
		call write_aim_reply (IMFT_AIM2, aim2_record_ptr, (4 * currentsize (aim2_record)));
	     end;

	     return;

	end write_aim2_reply;
%page;
/* Internal to establish_input_access_ceiling: attempts to read an AIM command */

read_aim_command:
	procedure (p_aim_type);

dcl  p_aim_type fixed binary (7) unaligned unsigned parameter;

	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = FIVE_MINUTES;		/* must be able to read it */
	     local_icri.record_ptr = addr (input_buffer);
	     local_icri.record_max_lth = length (input_buffer);

	     call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "read_command_record", addr (local_icri), code);

	     if code = 0 then			/* got something ... */
		if local_icri.record_type = p_aim_type then
		     return;			/* ... got the right type of command */

		else do;				/* ... anything else causes us to try over again */
		     call write_aim_reply (IMFT_RESYNCHRONIZE, null (), 0);
		     go to RESYNCHRONIZE_DRIVER;
		end;

	     else do;				/* some more serious error */
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.",
		     static.foreign_system.name);
		go to RETURN_FROM_INIT;
	     end;

	end read_aim_command;

     end establish_input_access_ceiling;
%page;
/* Synchronize an output driver: Write a SYNC1 command to the remote input driver with the our system ID and password and
   wait for a SYNC1 response.  On receiving the SYNC1 response, check if the remote system validated that ID/password
   combination and, if it did, validate the password/ID it sent us against the foreign system ID/password.  If the remote
   input driver's ID/password match, send a SYNC2 command indicating that synchronization is completed; otherwise, send a
   SYNC2 command explaining the synchronization failure */

synchronize_output_driver:
     procedure ();

	call write_sync_command (IMFT_SYNC1, static.local_system.name, static.local_system.password, 0, "");
						/* doesn't return on fatal errors */

	call read_sync_reply (IMFT_SYNC1);

	sync_record_ptr = addr (input_buffer);
	if sync_record.code ^= 0 then do;		/* remote input driver didn't like our ID/password */
	     code = imft_convert_status_code_$decode (sync_record.code);
	     if code = imft_et_$non_matching_ids then
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_,
		     "ID specified on local system is ^a; ID specified on remote system is ^a.",
		     static.local_system.name, sync_record.correct_userid);
	     else call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Validating local system ID.  ""^a""",
		     static.local_system.name);
	     go to RETURN_FROM_INIT;
	end;

	if static.foreign_system.name ^= sync_record.my_userid then do;
	     call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_ids, IMFT_DRIVER_,
		"ID specified on local system is ^a; ID specified on remote system is ^a.",
		static.foreign_system.name, sync_record.my_userid);
	     call write_sync_command (IMFT_SYNC2, "", "", imft_et_$non_matching_ids, static.foreign_system.name);
	     go to RETURN_FROM_INIT;
	end;

	if static.foreign_system.password ^= sync_record.my_password then do;
	     call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_passwords, IMFT_DRIVER_,
		"Validating foreign system ID.  ""^a""", sync_record.my_userid);
	     call write_sync_command (IMFT_SYNC2, "", "", imft_et_$non_matching_passwords, "");
	     go to RETURN_FROM_INIT;
	end;


	if local_icri.record_lth ^= 4 * currentsize (sync_record) then do;
						/* remote driver is pre 4.0 */
	     if foreign_system_version >= 4.0 then do;
		call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_versions, IMFT_DRIVER_,
		     "Remote system appears to be pre 4.0 but was specified to be ^a on local system.",
		     static.foreign_system.imft_version);
		call write_sync_command (IMFT_SYNC2, "", "", imft_et_$non_matching_versions, "");
		go to RETURN_FROM_INIT;
	     end;
	end;

	else if static.foreign_system.imft_version ^= sync_record.imft_version then do;
	     call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_versions, IMFT_DRIVER_,
		"Remote system claims to be ""^a"" but specified locally to be ""^a"".", sync_record.imft_version,
		static.foreign_system.imft_version);
	     call write_sync_command (IMFT_SYNC2, "", "", imft_et_$non_matching_versions, "");
	     go to RETURN_FROM_INIT;
	end;

/* success */
	call write_sync_command (IMFT_SYNC2, "", "", 0, "");
	call read_sync_reply (IMFT_SYNC2);
	if sync_record.code ^= 0 then do;
	     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Completing synchronization sequence.");
	     go to RETURN_FROM_INIT;
	end;

	return;					/* here iff synchronized OK */
%page;
/* Internal to syncrhonize_output_driver: attempts to transmit a SYNC command */

write_sync_command:
	procedure (p_sync_type, p_my_userid, p_my_password, p_code, p_correct_userid);

dcl  p_sync_type fixed binary (7) unaligned unsigned parameter;
dcl  (p_my_userid, p_correct_userid) character (*) parameter;
dcl  p_my_password character (8) aligned parameter;
dcl  p_code fixed binary (35) parameter;

dcl  code fixed binary (35);

	     sync_record_ptr = addr (output_buffer);	/* need a place to put it */
	     sync_record.my_userid = p_my_userid;
	     sync_record.my_password = p_my_password;
	     sync_record.code = imft_convert_status_code_$encode (p_code);
	     sync_record.correct_userid = p_correct_userid;
	     sync_record.imft_version = CURRENT_IMFT_VERSION;

	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = FIVE_MINUTES;		/* give the other side a chance to respond */
	     local_icri.record_type = p_sync_type;
	     local_icri.record_ptr = sync_record_ptr;
	     local_icri.record_lth = 4 * currentsize (sync_record);

	     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "write_command_record", addr (local_icri), code);

	     if code = 0 then return;			/* success */

	     else if code = imft_et_$reply_pending then	/* there's a reply to be checked out first ... */
						/* ... must be other side asking us to start over */
		call read_sync_reply (IMFT_RESYNCHRONIZE);

	     else do;				/* some more serious error */
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to synchronize with ^a.",
		     static.foreign_system.name);
		go to RETURN_FROM_INIT;
	     end;

	end write_sync_command;



/* Internal to synchronize_output_driver: attempts to read a SYNC reply */

read_sync_reply:
	procedure (p_sync_type);

dcl  p_sync_type fixed binary (7) unaligned unsigned parameter;

	     local_icri.version = ICRI_VERSION_1;
	     if static.automatic_operation & (p_sync_type = IMFT_SYNC1) then
		local_icri.timeout = 0;		/* wait forever for start of synchronization sequence */
	     else local_icri.timeout = FIVE_MINUTES;
	     local_icri.record_ptr = addr (input_buffer);
	     local_icri.record_max_lth = length (input_buffer);

	     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "read_reply_record", addr (local_icri), code);

	     if code = 0 then			/* got something ... */
		if local_icri.record_type = IMFT_RESYNCHRONIZE then go to RESYNCHRONIZE_DRIVER;
						/* ... remote system wants us to start over */

		else if (p_sync_type = 0) | (local_icri.record_type = p_sync_type) then return;
						/* ... got the right type of reply or will take any reply */

		else do;				/* ... anything else is residue from a now dead driver */
		     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
			"Unexpected reply code ^d from ^a; driver will attempt to resyncrhonize.",
			local_icri.record_type, static.foreign_system.name);
		     go to RESYNCHRONIZE_DRIVER;
		end;

	     else do;				/* some more serious error */
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to synchronize with ^a.",
		     static.foreign_system.name);
		go to RETURN_FROM_INIT;
	     end;

	end read_sync_reply;

     end synchronize_output_driver;
%page;
/* Establish the AIM access class ceiling for an output driver: Send an AIM1 command giving our system's AIM attributes
   definition and wait for the remote system to send an AIM1 reply with its AIM definition.  When we have both
   definitions, compute the common access ceiling (if possible), validate our explicit ceiling (if any) which must be less
   than the computed ceiling and, if all is OK, send an AIM2 command.  When the AIM2 response is received, check for the
   remote system requesting termination */

establish_output_access_ceiling:
     procedure ();

/* We will allocate storage for attributes, ensure any old stuff is freed. */

	call free_aim_attributes_storage;

	call get_system_aim_attributes_ (get_system_free_area_ (), AIM_ATTRIBUTES_VERSION_1,
	     static.local_system.aim_attributes_ptr, code);
	if code ^= 0 then do;			/* shouldn't get this but... */
	     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to get local AIM definition.");
	     go to RETURN_FROM_INIT;			/* ... other side will timeout */
	end;

	call write_aim_command (IMFT_AIM1, static.local_system.aim_attributes_ptr,
	     (4 * currentsize (static.local_system.aim_attributes_ptr -> aim_attributes)));

	call read_aim_reply (IMFT_AIM1);		/* aborts if we can't get it */

	if addr (input_buffer) -> aim_attributes.version ^= AIM_ATTRIBUTES_VERSION_1 then do;
	     call iodd_msg_ (ERROR, MASTER, error_table_$unimplemented_version, IMFT_DRIVER_,
		"Can not understand AIM definition from ^a.", static.foreign_system.name);
	     go to RETURN_FROM_INIT;			/* ... other side will timeout */
	end;

	allocate aim_attributes in (system_area) set (static.foreign_system.aim_attributes_ptr);
	static.foreign_system.aim_attributes_ptr -> aim_attributes = addr (input_buffer) -> aim_attributes;


/* Have exchanged AIM definitions: compute common access class ceiling, validate our explicit ceiling (if any), and send
   the AIM2 command */

	call compute_common_aim_ceiling_ (static.local_system.aim_attributes_ptr, static.local_system.access_ceiling,
	     static.foreign_system.aim_attributes_ptr, static.foreign_system.access_ceiling, code);
	if code ^= 0 then do;
CANT_ESTABLISH_CEILING:
	     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.",
		static.foreign_system.name);
	     call write_aim2_command (code);		/* let remote system know we lost */
	     go to RETURN_FROM_INIT;
	end;

	if local_explicit_ceiling_given then		/* check explicit ceiling */
	     if aim_check_$greater_or_equal (static.local_system.access_ceiling, local_explicit_ceiling) then do;
		call translate_aim_attributes_ (static.local_system.aim_attributes_ptr, local_explicit_ceiling,
		     static.foreign_system.aim_attributes_ptr, foreign_explicit_ceiling, code);
		if code ^= 0 then go to CANT_ESTABLISH_CEILING;
		if ^aim_check_$greater_or_equal (get_authorization_ (), local_explicit_ceiling) then do;
		     call convert_authorization_$to_string_short (local_explicit_ceiling, max_access_class_string,
			code);
		     if code ^= 0 then do;
			call convert_aim_attributes_ (local_explicit_ceiling, max_access_class_octal);
			max_access_class_string = max_access_class_octal;
		     end;
		     call iodd_msg_ (ERROR, MASTER, imft_et_$process_authorization_too_low, IMFT_DRIVER_,
			"Minimum process authorization must be ^[^a^;^ssystem_low^].",
			(max_access_class_string ^= ""), max_access_class_string);
		     call write_aim2_command (imft_et_$process_authorization_too_low);
		     go to RETURN_FROM_INIT;
		end;
	     end;

	     else do;				/* explicit ceiling is out of range */
		call iodd_msg_ (ERROR, MASTER, error_table_$ai_outside_common_range, IMFT_DRIVER_,
		     "Attempting to establish access ceiling with ^a.", static.foreign_system.name);
		call write_aim2_command (error_table_$ai_outside_common_range);
		go to RETURN_FROM_INIT;
	     end;

	else do;					/* not changing the ceiling: check driver's authoriztion */
	     if ^aim_check_$greater_or_equal (get_authorization_ (), static.local_system.access_ceiling) then do;
		call convert_authorization_$to_string_short (static.local_system.access_ceiling,
		     max_access_class_string, code);
		if code ^= 0 then do;
		     call convert_aim_attributes_ (static.local_system.access_ceiling, max_access_class_octal);
		     max_access_class_string = max_access_class_octal;
		end;
		call iodd_msg_ (ERROR, MASTER, imft_et_$process_authorization_too_low, IMFT_DRIVER_,
		     "Minimum process authorization must be ^[^a^;^ssystem_low^].", (max_access_class_string ^= ""),
		     max_access_class_string);
		call write_aim2_command (imft_et_$process_authorization_too_low);
		go to RETURN_FROM_INIT;
	     end;
	end;

	if ^static.old_version then do;
	     if local_explicit_floor_given then do;
		if ^aim_check_$greater_or_equal (static.local_system.access_ceiling, local_explicit_floor) then do;
						/* floor is not below common ceiling, we can't run */
		     call iodd_msg_ (ERROR, MASTER, error_table_$ai_outside_common_range,
			"Common access ceiling is not greater than or equal to minimum access class.");

		     call write_aim2_command (error_table_$ai_outside_common_range);
		     go to RETURN_FROM_INIT;
		end;

		static.local_system.access_floor = local_explicit_floor;
	     end;

	     else static.local_system.access_floor = ""b; /* use system_low */
	end;

	call write_aim2_command (NO_ERROR);		/* we're happy */

/* Wait for AIM2 reply and abort if foreign system requests it */

	call read_aim_reply (IMFT_AIM2);

	aim2_record_ptr = addr (input_buffer);

	if aim2_record.code ^= 0 then do;		/* remote system couldn't compute definition */
	     code = imft_convert_status_code_$decode (aim2_record.code);
	     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.",
		static.foreign_system.name);
	     go to RETURN_FROM_INIT;
	end;

	if static.old_version then
	     if local_explicit_ceiling_given then do;	/* OK: now set the true ceilings */
		static.local_system.access_ceiling = local_explicit_ceiling;
		static.foreign_system.access_ceiling = foreign_explicit_ceiling;
	     end;
	     else ;

	else do;					/* real agreed-on ceiling and floor are in AIM2 reply record */
	     call translate_aim_attributes_ (static.foreign_system.aim_attributes_ptr, aim2_record.computed_ceiling,
		static.local_system.aim_attributes_ptr, static.local_system.access_ceiling, code);
	     if code ^= 0 then do;
		call iodd_msg_ (ERROR, MASTER, code, "Translating final access ceiling.");
		go to RETURN_FROM_INIT;		/* no way to tell other system */
	     end;

	     static.foreign_system.access_ceiling = aim2_record.computed_ceiling;

	     call translate_aim_attributes_ (static.foreign_system.aim_attributes_ptr, aim2_record.computed_floor,
		static.local_system.aim_attributes_ptr, static.local_system.access_floor, code);
	     if code ^= 0 then do;
		call iodd_msg_ (ERROR, MASTER, code, "Translating final access floor.");
		go to RETURN_FROM_INIT;		/* no way to tell other system */
	     end;

	     static.foreign_system.access_floor = aim2_record.computed_floor;
	end;

	return;
%page;
/* Internal to establish_output_access_ceiling: attempts to transmit an AIM command */

write_aim_command:
	procedure (p_aim_type, p_record_ptr, p_record_lth);

dcl  p_aim_type fixed binary (7) unaligned unsigned parameter;
dcl  p_record_ptr pointer parameter;
dcl  p_record_lth fixed binary (21) parameter;
dcl  code fixed binary (35);

	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = FIVE_MINUTES;		/* give the other side a chance */
	     local_icri.record_type = p_aim_type;
	     local_icri.record_ptr = p_record_ptr;
	     local_icri.record_lth = p_record_lth;

	     call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "write_command_record", addr (local_icri), code);

	     if code = 0 then return;			/* success */

	     else if code = imft_et_$reply_pending then	/* there's a reply to be checked out first ... */
						/* ... must be other side asking us to start over */
		call read_aim_reply (IMFT_RESYNCHRONIZE);

	     else do;				/* some more serious error */
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.",
		     static.foreign_system.name);
		go to RETURN_FROM_INIT;
	     end;

	     return;

	end write_aim_command;



/*  Internal to establish_output_access_ceiling: attempts to transmit an AIM2 command */

write_aim2_command:
	procedure (p_code);

dcl  p_code fixed binary (35) parameter;
dcl  record_size fixed binary (21);

	     aim2_record_ptr = addr (output_buffer);	/* need a place to put it */
	     aim2_record.code = imft_convert_status_code_$encode (p_code);

	     if static.old_version then do;
		v2_aim2_record.computed_ceiling = static.local_system.access_ceiling;
		v2_aim2_record.explicit_ceiling_given = local_explicit_ceiling_given;
		v2_aim2_record.explicit_ceiling = local_explicit_ceiling;
		record_size = 4 * currentsize (v2_aim2_record);
	     end;

	     else do;
		aim2_record.computed_ceiling = static.local_system.access_ceiling;
		aim2_record.explicit_ceiling_given = local_explicit_ceiling_given;
		aim2_record.explicit_ceiling = local_explicit_ceiling;
		aim2_record.computed_floor = static.local_system.access_floor;
		aim2_record.explicit_floor_given = local_explicit_floor_given;
		aim2_record.explicit_floor = local_explicit_floor;

		record_size = 4 * currentsize (aim2_record);
	     end;

	     call write_aim_command (IMFT_AIM2, aim2_record_ptr, record_size);

	     return;

	end write_aim2_command;
%page;
/* Internal to establish_output_access_ceiling: attempts to read an AIM reply */

read_aim_reply:
	procedure (p_aim_type);

dcl  p_aim_type fixed binary (7) unaligned unsigned parameter;

	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = FIVE_MINUTES;		/* must be able to read it */
	     local_icri.record_ptr = addr (input_buffer);
	     local_icri.record_max_lth = length (input_buffer);

	     call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "read_reply_record", addr (local_icri), code);

	     if code = 0 then			/* got something ... */
		if local_icri.record_type = IMFT_RESYNCHRONIZE then go to RESYNCHRONIZE_DRIVER;
						/* ... remote system wants us to start over */

		else if local_icri.record_type = p_aim_type then return;
						/* ... got the right type of reply */

		else do;				/* ... anything else is residue from a now dead driver */
		     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
			"Unexpected reply code ^d from ^a; driver will atempt to resynchronize.",
			local_icri.record_type, static.foreign_system.name);
		     go to RESYNCHRONIZE_DRIVER;
		end;

	     else do;				/* some more serious error */
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.",
		     static.foreign_system.name);
		go to RETURN_FROM_INIT;
	     end;

	end read_aim_reply;

     end establish_output_access_ceiling;
%page;
/* Check for remote input driver termination:  This procedure is called every
   iodd_static.wakeup_time seconds while an output driver is idle.  It checks
   to see if the remote system has sent a reply requesting resynchronization
   or logout of the local output driver */

check_for_resync_request:
     procedure ();

/* If we are a dial sender, and we are supposed to drop the line to
   conserve network costs when the driver goes idle, then drop it here
   and signal the dial receiver that we are going away for a while.

   We will pick up and reconnect the line in the request processing when
   we see that the iocbp is null. */

	if static.idle_line_drop = "1"b then do;

/* Determine if we are to idle the line yet.  Each time the coord sends us
   a daemon idle, we increment this counter.  When we have seen enough then
   we will idle the line.  The prevents rapid line drops and raises. */

	     static.idle_delay = static.idle_delay + 1;
	     if static.idle_delay <= static.idle_delay_count then goto delay_idle_down;
						/* wait a bit */

	     if ds_ptr -> driver_status.dev_out_iocbp = null then goto idled;

	     iodd_static.re_init_in_progress = "1"b;	/* re-initialize the driver */
	     iodd_static.slave.log_msg = "1"b;		/* send to log and slave */
	     call iodd_msg_ (LOG, BOTH, 0, "", "^a ^a ^[input^;output^] driver going to sleep at ^a.",
		static.foreign_system.name, FUNCTION_NAMES (static.function), static.input_driver,
		date_time_$format ("date_time", clock (), "", ""));
	     local_icri.record_type = IMFT_LOGOUT;
	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = 15;			/* ... doesn't really have to get through */
	     local_icri.record_ptr = null ();		/* ... no associated data */
	     local_icri.record_lth, local_icri.record_max_lth = 0;

	     if ds_ptr -> driver_status.dev_out_iocbp ^= null () then do;
		call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "write_command_record", addr (local_icri),
		     ignore_code);
	     end;

	     call iox_$control (iodd_static.slave_out, "runout", null (), ignore_code);
	     call drop_device ();

idled:
	     call continue_to_signal_ (ignore_code);
	     return;
	end;

delay_idle_down:
	call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "read_status", addr (trsi), code);
	if code ^= 0 then do;
COULD_NOT_RAISE_REMOTE:
	     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_,
		"Fatal error while checking status of remote input driver; driver will re-initialize.");
	     signal condition (re_init);
	end;

	if trsi.input_pending then do;		/* see what's going on */
	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = FIVE_MINUTES;		/* in case the remote input driver is sick */
	     local_icri.record_ptr = addr (input_buffer); /* need to put is someplace */
	     local_icri.record_max_lth = length (input_buffer);
	     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "read_reply_record", addr (local_icri), code);
	     if code ^= 0 then go to COULD_NOT_RAISE_REMOTE;

	     if local_icri.record_type = IMFT_RESYNCHRONIZE then signal condition (imft_resynchronize_driver_);

	     else if local_icri.record_type = IMFT_LOGOUT then signal condition (imft_remote_logout_);

	     else do;				/* some unexpected event */
		call iodd_msg_ (NORMAL, MASTER, 0, IMFT_DRIVER_,
		     "Unexpected reply code ^d from ^a; driver will re-initialize.", local_icri.record_type,
		     static.foreign_system.name);
		signal condition (re_init);
	     end;
	end;

	call continue_to_signal_ (ignore_code);

	return;

     end check_for_resync_request;
%page;
/* Free allocated storage if it exists. */

free_aim_attributes_storage:
     proc;

/* aim attributes occupy allocated storage.  We need to free it prior to
   allocating new stuff.  Otherwise we end up cluttering area.linker. */

	if static.foreign_system.aim_attributes_ptr ^= null () then
	     free static.foreign_system.aim_attributes_ptr -> aim_attributes;
	static.foreign_system.aim_attributes_ptr = null ();

	if static.local_system.aim_attributes_ptr ^= null () then
	     free static.local_system.aim_attributes_ptr -> aim_attributes;
	static.local_system.aim_attributes_ptr = null ();

     end free_aim_attributes_storage;
%page;
/* Drop the device and hang it up */

drop_device:
     procedure ();

dcl  send_hangup bit (1) aligned;
dcl  iocb_ptr ptr;

	send_hangup = "1"b;
	go to DROP_DEVICE_COMMON;


/* Drop the device only */

detach_device:
     entry ();

	if static.dial_service then
	     send_hangup = "1"b;
	else send_hangup = "0"b;

DROP_DEVICE_COMMON:
	iodd_static.attach_name = "*";
	ds_ptr -> driver_status.attached = "0"b;
	iocb_ptr = ds_ptr -> driver_status.dev_out_iocbp;
	ds_ptr -> driver_status.dev_out_iocbp, ds_ptr -> driver_status.dev_in_iocbp = null ();

/* Kill any possible associated minor device. */

	if iodd_static.assigned_devices = 2 then do;	/* copy necessary stuff to second minor */
						/* device's status structure */
	     devp = iodd_static.driver_list_ptr -> driver_ptr_list.stat_segp (2);
	     devp -> driver_status.attached = "0"b;
	     devp -> driver_status.ready = "0"b;
	     devp -> driver_status.dev_out_iocbp = ds_ptr -> driver_status.dev_out_iocbp;
	     devp -> driver_status.dev_in_iocbp = ds_ptr -> driver_status.dev_in_iocbp;
	end;

	iodd_static.attach_name = "*";

	call close_and_detach (iocb_ptr, send_hangup);

/* If we were an in-dial then we have to drop the dial service and
   kill the event channel too. */

	if static.in_dial_qualifier ^= "" & dma.dial_channel ^= 0 then do;
	     call ipc_$decl_ev_wait_chn (dma.dial_channel, code);
	     call dial_manager_$shutoff_dials (addr (dma), code);
	     call ipc_$drain_chn (dma.dial_channel, code);
	     call ipc_$delete_ev_chn (dma.dial_channel, code);
	     dma.dial_channel = 0;
	end;

	call continue_to_signal_ (ignore_code);		/* in case this is called from a handler */

	return;

     end drop_device;
%page;
/* Close and detach the line to the remote system */

close_and_detach:
     procedure (P_iocb_ptr, P_send_hangup);

dcl  P_iocb_ptr pointer parameter;
dcl  P_send_hangup bit (1) aligned;

	if P_iocb_ptr = null () then return;		/* may be used before anything's attached */

	if P_send_hangup then do;			/* caller requested a hangup of the line */
	     if static.in_dial_qualifier ^= "" then	/* ignore hangups */
		call ipc_$decl_ev_call_chn (dma.dial_channel, nulle, null (), 1, code);
	     else do;
		hangup_info.entry = nulle;		/* ... prevent the hangup from causing a reinit */
		hangup_info.data_ptr = null ();
		hangup_info.priority = 20;
		call iox_$control (P_iocb_ptr, "hangup_proc", addr (hangup_info), ignore_code);
	     end;

/* Wait for any line runout to arrive at the target before dropping the line */

	     call timer_manager_$sleep (FIVE_SECONDS, RELATIVE_SECONDS);
	     call iox_$control (P_iocb_ptr, "hangup", null (), ignore_code);
	end;

	call iox_$close (P_iocb_ptr, ignore_code);

	call iox_$detach_iocb (P_iocb_ptr, ignore_code);
	call iox_$destroy_iocb (P_iocb_ptr, ignore_code);
	return;
     end close_and_detach;

/* May be invoked when a hangup occurs */

nulle:
     procedure ();

	return;

     end nulle;
%page;
/* Attach the line to the remote system */

attach_line:
     procedure ();

dcl  attach_description character (512) varying;
dcl  character_line character (local_icri.record_lth) unaligned based (local_icri.record_ptr);
dcl  code fixed bin (35);
dcl  error_message char (64);
dcl  io_module char (32);
dcl  no_dialed fixed bin;
dcl  open_mode fixed binary;
dcl  previous_attach_code fixed bin (35);
dcl  prev_proto_error bit (1);
dcl  sleep_time fixed bin (71);
dcl  which_channel char (32);
%skip (5);
/* Attach a line with the target system.

   Two forms of attachment are possible:

   1. argument described attachment.
   This attachment takes the attach description from the iod_tables
   or the args file.  It describes the io module and the line information.

   2. in-dial described attachment.
   This attachment takes the attach description from the dial_manager
   information returned when a dial-up for the dial-name occurs.
   This permits attach_line to determine the io module and line information.

   Attachment can be a simple line attachment, or can include a protocol
   data handshake.

   Error processing is such that only the first occurance of a particular error
   is noted in the log, and then error retrying occurs.  This holds for
   line attachment, opening and protocol handshake.  If a line error occurs,
   the device is dropped and a re-attachment, opening and handshake is done.
   This ensures a clean line attachment.  */


/* If line was previously attached we will drop the device here and try
   again. */

	if ds_ptr -> driver_status.dev_out_iocbp ^= null () then call drop_device;
						/* Ensure we are clean */
	previous_attach_code = 0;
	prev_proto_error = "0"b;			/* no handshake error outstanding */

retry_attach:
	sleep_time = FIVE_MINUTES;			/* default wait */

/* If we are an in_dial, then setup the dial channel and wait for a
   connection.  When a connection has occurred, we determine the
   io module name, etc., and continue as if a suitable args input
   had been given to us. */

	on cleanup call drop_device;			/* we drop unattached */

	if static.in_dial_qualifier ^= "" then do;
	     call ipc_$create_ev_chn (dma.dial_channel, code);
	     if code ^= 0 then do;
		error_message = "couldn't create an event channel";
		goto IN_DIAL_ERROR;
	     end;

	     dma.version = 1;
	     dma.dial_qualifier = rtrim (static.in_dial_qualifier);

	     call dial_manager_$allow_dials (addr (dma), code);

	     if code ^= 0 then do;
		error_message = "error from dial_manager_$allow_dials call";

IN_DIAL_ERROR:
		call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_,
		     "Creating dial channel ^a for ^[input^;output^] driver to ^a ^a: ^a.", static.in_dial_qualifier,
		     static.input_driver, static.foreign_system.name, FUNCTION_NAMES (static.function), error_message)
		     ;
		goto RETURN_FROM_INIT;
	     end;

	     event_wait_channel.channel_id = dma.dial_channel;
	     call ipc_$block (addr (event_wait_channel), addr (ev_wait_info), code);

/* We now have a connection.  Determine information about it, and formulate
   the correct value for static.input_attach_description from the io_module
   name and the line name.  */

	     call convert_dial_message_$return_io_module (ev_wait_info.message, which_channel, io_module, no_dialed,
		status_flags, code);
	     if code ^= 0 then do;
		error_message = "couldn't convert the dial message";
		goto IN_DIAL_ERROR;
	     end;

	     if ^status_flags.dialed_up then do;
		error_message = "have a connection but channel is not dialed up";
		goto IN_DIAL_ERROR;
	     end;

	     static.input_attach_description = rtrim (io_module) || " " || rtrim (which_channel);
	     call iodd_msg_ (NORMAL, MASTER, 0, "", "Dial Channel ^a connected from ^a.",
		static.input_attach_description, static.foreign_system.name);
	end;
%page;
/* Complete connection by attaching the line.  We have to determine the
   information and connect a dial-out channel. */

	if static.old_version then
	     attach_description = "old_imft_io_ -direction ";
	else attach_description = "imft_io_ -direction ";

	if static.input_driver then do;
	     attach_description = attach_description || " input ";
	     open_mode = Stream_input;
	end;
	else do;
	     attach_description = attach_description || " output ";
	     open_mode = Stream_output;
	end;

	if static.single_switch then do;
	     attach_description = attach_description || " -io_description ";
	     attach_description = attach_description || requote_string_ (rtrim (static.input_attach_description));
	end;

	else do;
	     attach_description = attach_description || " -input_description ";
	     attach_description = attach_description || requote_string_ (rtrim (static.input_attach_description));

	     attach_description = attach_description || " -output_description ";
	     attach_description = attach_description || requote_string_ (rtrim (static.output_attach_description));
	end;

	if static.debug_mode then attach_description = attach_description || " -debug";
	if static.copy_data then attach_description = attach_description || " -copy_data";

	ds_ptr -> driver_status.dev_out_stream = get_switch_name ();

	call iox_$attach_ioname ((ds_ptr -> driver_status.dev_out_stream), ds_ptr -> driver_status.dev_out_iocbp,
	     (attach_description), code);
	ds_ptr -> driver_status.dev_in_iocbp = ds_ptr -> driver_status.dev_out_iocbp;

	if code ^= 0 then go to ACTION_ERROR;


	call iox_$open (ds_ptr -> driver_status.dev_out_iocbp, open_mode, "0"b, code);
	if code ^= 0 then
	     go to ACTION_ERROR;
	else previous_attach_code = 0;

/* Start the line going if we have attached an in-dial line. */

	if static.in_dial_qualifier ^= "" then
	     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "start", null (), code);

	if static.out_dial_text = "" then call set_hangup_proc ();
						/* enable handling of hangups */

	call get_data_channel_names ();		/* determine names of channels forming the connection */

/* Connection Protocol handshake. */

	if static.in_dial_qualifier ^= "" then call put_chars ("IMFT TRANSPORT ESTABLISHED
");
	if static.out_dial_text = "" then return;	/* normal connection */
%page;
/* Handle connection protocol necessary for line attachment to a remote system.

   This consists of waiting for the trigger_text, then emitting the dial_text
   and completing the protocol. */

	call ipc_$decl_ev_call_chn (dma.dial_channel,	/* ignore hangups */
	     protocol_hangup, stat_p, 1, code);

	call wait_for_trigger (rtrim (static.trigger_text));

/* emit the dial text, and validate the dial connection */

	call put_chars (rtrim (static.out_dial_text) || NL);
	call get_line ();
	if index (character_line, " dialed to ") = 0 then do;
hangup_protocol:
	     if ^prev_proto_error then
		call iodd_msg_ (NORMAL, MASTER, 0, IMFT_DRIVER_,
		     "Protocol error - received ""^a""^/driver will retry every ^i minute^[s^;^].", character_line,
		     static.sleep_time, static.sleep_time > 1);

	     sleep_time = static.sleep_time * ONE_MINUTE;
	     prev_proto_error = "1"b;
	     goto ACTION_RETRY;
	end;
	call wait_for_trigger ("IMFT TRANSPORT ESTABLISHED
");
	call set_hangup_proc;

	return;

/* Action errors are processed here for line errors, such as attach and open.
   If error codes are the same as before then no message is emitted and a
   silent retry is performed after a 5 minute wait. */

ACTION_ERROR:
	if ^static.automatic_operation | code ^= previous_attach_code then
	     call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_,
		"Attaching line for ^a ^a ^[input^;output^] driver^/^-attach description: ^a",
		static.foreign_system.name, FUNCTION_NAMES (static.function), static.input_driver, attach_description)
		;
	prev_proto_error = "0"b;			/* no prev error */

/* Entry here is from the protocol error.  We want to handle the normal
   automatic_operation actions and retry the attach and handshake again. */

ACTION_RETRY:
	if static.automatic_operation			/* keep trying every 5 minutes, so operator */
						/* doesn't have to do anything */
	then do;
	     previous_attach_code = code;
	     call drop_device;
	     call timer_manager_$sleep (sleep_time, RELATIVE_SECONDS);
	     goto retry_attach;
	end;

	else go to RETURN_FROM_INIT;			/* NO RETRY */

/* dummy procedure to handle line hangup during protocol handshaking. */

protocol_hangup:
	proc;
	     goto hangup_protocol;
	end protocol_hangup;

/* Internal to attach_line: put and get characters at the transport level. */

put_chars:
	procedure (characters);

dcl  characters character (*) parameter;

	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = FIVE_MINUTES;
	     local_icri.record_ptr = addr (characters);
	     local_icri.record_lth = length (characters);
	     local_icri.record_max_lth = length (characters);

	     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "put_transport_chars", addr (local_icri), code);
	     if code ^= 0 then goto hangup_protocol;
	     if static.debug_connect then call iodd_msg_ (NORMAL, MASTER, 0, "", "S-""^a""", rtrim (characters, "
"));
	     return;
	end;

get_line:
	procedure ();

	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = FIVE_MINUTES;
	     local_icri.record_ptr = addr (character_buffer);
	     local_icri.record_lth = 0;
	     local_icri.record_max_lth = length (character_buffer);

	     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "get_transport_line", addr (local_icri), code);
	     if code ^= 0 then goto hangup_protocol;
	     if static.debug_connect then call iodd_msg_ (NORMAL, MASTER, 0, "", "R-""^a""", rtrim (character_line, "
"));
	     return;
	end;

/* Wait for a protocol triggering string to be received. */

wait_for_trigger:
	proc (string);

dcl  string char (*);

	     do trigger_loop_count = 1 to MAX_TRIGGER_LOOP_COUNT;
		call get_line;
		if index (character_line, string) ^= 0 then return;
						/* got it! */
	     end;					/* didn't get satisfactory response from other end */
	     call iodd_msg_ (ERROR, MASTER, error_table_$fatal_error, IMFT_DRIVER_,
		"Dial-out protocol retry limit reached, attaching line for ^a ^a ^[input^;output^] driver^/^-attach description: ^a",
		static.foreign_system.name, FUNCTION_NAMES (static.function), static.input_driver, attach_description)
		;
	     go to hangup_protocol;

	end wait_for_trigger;

/* Internal to attach_line: determine the name for the I/O switch */

get_switch_name:
	procedure () returns (character (32));

	     attachment_count = attachment_count + 1;

	     if attachment_count > 999 then		/* avoid conversion errors */
		attachment_count = 1;

	     if static.input_driver then
		return ("input." || ltrim (convert (attachment_count_pic, attachment_count)));
	     else return ("output." || ltrim (convert (attachment_count_pic, attachment_count)));

	end get_switch_name;



/* Internal to attach_line: set the device hangup procedure for the line */

set_hangup_proc:
	procedure ();

	     if static.in_dial_qualifier ^= "" then
		call ipc_$decl_ev_call_chn (dma.dial_channel, iodd_hangup_, stat_p, 1, code);
	     else do;
		hangup_info.entry = iodd_hangup_;
		hangup_info.data_ptr = stat_p;
		hangup_info.priority = 1;
		call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "hangup_proc", addr (hangup_info), code);
	     end;

	     if code ^= 0 then
		call iodd_msg_ (NORMAL, MASTER, code, IMFT_DRIVER_,
		     "Warning: Could not establish handler for disconnection from ^a.", static.foreign_system.name);

	     return;

	end set_hangup_proc;

/* Internal to attach_line: determine the names of the channels connected
   used for data transmission.  These are used in various messages to notify
   logs as to the lines attached for input and output.

   We fill in the iodd_static.attach_name variable to enable the status
   request response to indicate what line is currently attached.  Cleanup
   code is necessary to restore the "*" string to this variable outside the
   driver and any time the line is unattached. */

get_data_channel_names:
	procedure ();

	     have_channel_names = "0"b;		/* assume failure */

	     local_gcn.version = GET_CHANNEL_NAMES_VERSION_1;

	     call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "get_channel_names", addr (local_gcn), code);

	     if code = 0 then do;
		have_channel_names = "1"b;
		if static.input_driver then
		     iodd_static.attach_name = local_gcn.input_channel;
		else iodd_static.attach_name = local_gcn.output_channel;
	     end;

	     else if code ^= imft_et_$cant_get_channel_names then
		call iodd_msg_ (NORMAL, MASTER, code, IMFT_DRIVER_,
		     "Warning: Could not determine channel names for ^a ^a ^[input^;output^] driver.",
		     static.foreign_system.name, FUNCTION_NAMES (static.function), static.input_driver);

	     return;

	end get_data_channel_names;

     end attach_line;
%page;
/* Make sure request type name is valid in form and corresponds to foreign system name */

validate_request_type:
     procedure (devp);

dcl  devp pointer parameter;
dcl  req_type_site character (32);

	if substr (devp -> driver_status.req_type_label, 1, 3) = "To_" then
	     req_type_site = substr (before (devp -> driver_status.req_type_label, "."), 4);
	else if substr (devp -> driver_status.req_type_label, 1, 5) = "From_" then
	     req_type_site = substr (before (devp -> driver_status.req_type_label, "."), 6);
	else do;
	     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "request type ""^a"" is not in correct format.",
		devp -> driver_status.req_type_label);
	     go to RETURN_FROM_INIT;
	end;

	if req_type_site ^= static.foreign_system.name then do;
	     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
		"Request type (^a) does not correspond to foreign system (^a).", devp -> driver_status.req_type_label,
		static.foreign_system.name);
	     go to RETURN_FROM_INIT;
	end;
     end validate_request_type;
%page;
/* Validates that a value is either "yes" or "no" and returns true or false accordingly */

yes_no_p:
     procedure (P_keyword, P_value) returns (bit (1) aligned);

dcl  (P_keyword, P_value) character (*) parameter;

	if P_value = "y" then P_value = "yes";
	if P_value = "n" then P_value = "no";

	if (P_value ^= "yes") & (P_value ^= "no") then do;
	     call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_,
		"The value of the ""^a"" keyword must be ""yes"" or ""no""; not ""^a"".", P_keyword, P_value);
	     go to RETURN_FROM_INIT;
	end;

	return (P_value = "yes");

     end yes_no_p;
%page;
/* Parameters */

dcl  P_stat_p pointer parameter;			/* init: -> iodd_static for this driver */

dcl  P_source fixed binary parameter;			/* command: source of the command (master/slave) */
dcl  P_state fixed binary parameter;			/* command: current state of driver (normal/quit/request) */
dcl  P_arglist_ptr pointer parameter;			/* command: -> structure defining command and arguments */
dcl  P_code fixed binary (35) parameter;		/* command: status code */

dcl  P_condition_info_ptr pointer parameter;		/* default_handler: -> description of the condition */


/* Remaining declarations */

dcl  major_args character (major_args_lth) unaligned based (major_args_ptr);
dcl  major_args_lth fixed binary (21);
dcl  major_args_ptr pointer;

dcl  major_args_path character (204) static;		/* need room for archive component */
dcl  major_args_dirname character (168) static;
dcl  (major_args_ename, major_args_component) character (32) static;
dcl  major_args_bc fixed binary (24) static;

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer static;

dcl  1 arglist aligned based (arglist_ptr),		/* structure defining a command and it's arguments */
       2 max_tokens fixed binary,			/* # of tokens allocated */
       2 n_tokens fixed binary,			/* # of tokens in command line */
       2 command character (64) varying,
       2 arguments (arglist.n_tokens - 1) character (64) varying;
dcl  arglist_ptr pointer;

dcl  1 local_terminal_info aligned like terminal_info automatic;

dcl  1 trsi aligned like tty_read_status_info;

dcl  1 event_channel_list aligned based,		/* list of event channels associated with driver */
       2 n_channels fixed binary,
       2 channels (12) fixed binary (71);

dcl  1 hangup_info aligned,				/* for "hangup_proc" control order */
       2 entry entry () variable,
       2 data_ptr pointer,
       2 priority fixed binary;

dcl  1 local_icri aligned like icri static;		/* for synchronization */

dcl  1 local_gcn aligned like get_channel_names static;	/* to get input/output channel names */
dcl  have_channel_names bit (1) aligned static;

dcl  1 dma like dial_manager_arg static;
dcl  1 ev_wait_info static like event_wait_info;

dcl  1 status_flags aligned static,
       (
       2 dialed_up bit (1),
       2 hung_up bit (1),
       2 control bit (1),
       2 pad bit (33)
       ) unal;

dcl  ds_ptr pointer static;				/* -> driver_status for this driver */
dcl  devp pointer static;				/* -> driver_status for a minor device */
dcl  rd_ptr pointer static;				/* -> request_descriptor of current request */
dcl  p pointer;
dcl  i fixed binary;

dcl  max_access_class_string character (256) static;
dcl  max_access_class_octal character (32) aligned static;
dcl  min_access_class_string character (256) static;
dcl  min_access_class_octal character (32) aligned static;
dcl  (local_explicit_ceiling, foreign_explicit_ceiling) bit (72) aligned static;
dcl  (local_explicit_floor, foreign_explicit_floor) bit (72) aligned static;
dcl  (local_explicit_ceiling_given, local_explicit_floor_given) bit (1) aligned static;
dcl  foreign_system_version float binary static;

dcl  keyword_value character (32) static;

dcl  (code, ignore_code, saved_code) fixed binary (35) static;
dcl  my_ring fixed binary (3);

dcl  test_initiate_entry entry () variable;

dcl  character_buffer character (256) static;		/* for transport connection protocol */
dcl  temp_attach_description character (256) static;
dcl  trigger_loop_count fixed bin static;
dcl  source fixed binary static;			/* source of the command being processed */
dcl  value fixed binary (35) static;

dcl  condition character (32) static;

dcl  (input_buffer, output_buffer) character (2048) static; /* for reading/writing commands/replies */
dcl  (saved_test_entry, send_logout_record) bit (1) aligned static;

dcl  1 static aligned like imft_driver_info static;	/* complete description of this driver */
dcl  1 static_fis_info aligned like fis_info static;	/* used by imft_find_input_switch_ */
dcl  static_pause_time fixed binary (71) static;		/* # of seconds to pause between requests */

dcl  attachment_count fixed binary static initial (0);
dcl  attachment_count_pic picture "999" static;

dcl  IMFT_DRIVER_ character (32) static options (constant) initial ("imft_driver_");
dcl  CURRENT_IMFT_VERSION character (3) static options (constant) initial ("4.0");

dcl  FIVE_MINUTES fixed binary static options (constant) initial (300);
dcl  FIVE_SECONDS fixed binary (71) static options (constant) initial (5);
dcl  MAX_TRIGGER_LOOP_COUNT fixed binary static options (constant) initial (20);
dcl  NO_ERROR fixed binary (35) static options (constant) initial (0);
dcl  ONE_MINUTE fixed binary static options (constant) initial (60);

dcl  NL character (1) static options (constant) initial ("
");
dcl  WHITESPACE character (5) static options (constant) initial (" 	
");						/* SP HT NL VT FF */

dcl  INITIAL_IMFT_RATE fixed binary static options (constant) initial (4800);

dcl  LISTEN_COMMAND_LEVEL fixed binary static options (constant) initial (1);
						/* command entered from iodd_listen_ with a ready device */

dcl  (
     error_table_$ai_outside_common_range,
     error_table_$action_not_performed,
     error_table_$bad_conversion,
     error_table_$fatal_error,
     error_table_$inconsistent,
     error_table_$noarg,
     error_table_$unimplemented_version
     ) fixed binary (35) external;

dcl  (
     imft_et_$cant_get_channel_names,
     imft_et_$computed_ceiling_mismatch,
     imft_et_$explicit_ceiling_mismatch,
     imft_et_$explicit_floor_mismatch,
     imft_et_$non_matching_ids,
     imft_et_$non_matching_passwords,
     imft_et_$non_matching_versions,
     imft_et_$process_authorization_too_low,
     imft_et_$reply_pending
     ) fixed binary (35) external;

dcl  add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible;
dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$greater entry (bit (72) aligned, 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  compute_common_aim_ceiling_ entry (pointer, bit (72) aligned, pointer, bit (72) aligned, fixed binary (35));
dcl  continue_to_signal_ entry (fixed binary (35));
dcl  convert_aim_attributes_ entry (bit (72) aligned, character (32) aligned);
dcl  convert_authorization_$from_string entry (bit (72) aligned, character (*), fixed binary (35));
dcl  convert_authorization_$to_string_short entry (bit (72) aligned, character (*), fixed binary (35));
dcl  convert_dial_message_$return_io_module
	entry (fixed bin (71), char (*), char (*), fixed bin, 1 aligned, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal,
	2 bit (33) unal, fixed bin (35));
dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl  dial_manager_$allow_dials entry (ptr, fixed bin (35));
dcl  dial_manager_$shutoff_dials entry (ptr, fixed bin (35));
dcl  expand_pathname_$component entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  get_authorization_ entry () returns (bit (72) aligned);
dcl  get_ring_ entry () returns (fixed bin (3));
dcl  get_system_aim_attributes_ entry (pointer, character (8), pointer, fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  imft_convert_status_code_$decode entry (fixed binary (35)) returns (fixed binary (35));
dcl  imft_convert_status_code_$encode entry (fixed binary (35)) returns (fixed binary (35));
dcl  imft_pnt_interface_$get_system_password entry (character (*), character (8) aligned, fixed binary (35));
dcl  imft_receive_object_ entry (pointer, pointer, fixed binary (35));
dcl  imft_transmit_object_ entry (pointer, pointer, pointer, fixed binary (35));
dcl  imft_transmit_object_$abort_running_request entry (character (*));
dcl  initiate_file_$component
	entry (character (*), character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
dcl  iodd_command_processor_ entry (fixed binary, fixed binary, character (*), fixed binary (35));
dcl  iodd_hangup_ entry (ptr);
dcl  iodd_listen_ entry (pointer);
dcl  iodd_msg_ entry () options (variable);
dcl  iodd_parse_$args entry (char (*) var, char (*)) returns (char (256) var);
dcl  iodd_quit_handler_ entry ();
dcl  iodd_quit_handler_$command_level entry ();
dcl  iox_$attach_ioname entry (character (*), pointer, character (*), fixed binary (35));
dcl  iox_$close entry (pointer, fixed binary (35));
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  iox_$detach_iocb entry (pointer, fixed binary (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin (35));
dcl  iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
dcl  ipc_$decl_ev_wait_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl  pathname_$component entry (character (*), character (*), character (*)) returns (character (194));
dcl  requote_string_ entry (character (*)) returns (character (*));
dcl  system_privilege_$initiate entry ();
dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl  timer_manager_$sleep entry (fixed binary (71), bit (2));
dcl  translate_aim_attributes_ entry (pointer, bit (72) aligned, pointer, bit (72) aligned, fixed binary (35));

dcl  (cleanup, daemon_idle, daemon_logout, daemon_new_device, daemon_slave_logout, linkage_error, imft_debug_,
     imft_remote_logout_, imft_resynchronize_driver_, no_coord, quit, re_init, resume) condition;

dcl  (addr, before, clock, convert, currentsize, divide, index, length, ltrim, null, rtrim, substr) builtin;
%page;
%include access_mode_values;
%page;
%include aim_attributes;
%page;
%include condition_info;
%page;
%include dial_manager_arg;
%page;
%include driver_ptr_list;
%page;
%include driver_status;
%page;
%include event_wait_channel;
%include event_wait_info;
%page;
%include "_imft_cri";
%page;
%include "_imft_driver_info";
%page;
%include "_imft_fis_info";
%page;
%include "_imft_ft_request";
%page;
%include "_imft_get_channel_names";
%page;
%include "_imft_std_commands";
%page;
%include iod_constants;
%page;
%include iod_tables_hdr;
%page;
%include iodd_msg_constants;
%page;
%include iodd_static;
%page;
%include iox_modes;
%page;
%include mseg_message_info;
%page;
%include queue_msg_hdr;
%page;
%include request_descriptor;
%page;
%include set_term_type_info;
%include terminal_info;
%page;
%include terminate_file;
%page;
%include timer_manager_constants;
%page;
%include tty_read_status_info;

     end imft_driver_;




		    imft_et_.alm                    10/14/88  1248.7rew 10/14/88  1212.6       21186



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1988                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************

" Error table for the Inter-Multics File Transfer Facility

" Created:  April 1982 by G. Palter
" Modified: July 1982 by G. Palter for true AIM support


" HISTORY COMMENTS:
"  1) change(88-07-11,Beattie), approve(88-08-01,MCR7948),
"     audit(88-10-11,Farley), install(88-10-14,MR12.2-1165):
"     Add entry for mismatching versions.
"                                                      END HISTORY COMMENTS


	name	imft_et_

	include	et_macros

	et	imft_et_


ec   cant_access_pnt,nopnt,
	(IMFT driver process can not access the system PNT.)

ec   cant_get_channel_names,nochnnms,
	(IMFT driver can not determine the names of the channels used for data transmission.)

ec   computed_ceiling_mismatch,^eqcc,
	(Local and remote systems did not compute the same access class ceiling.)

ec   explicit_ceiling_mismatch,^eqec,
	(max_access_class specified on local and remote systems are isolated.)

ec   explicit_floor_mismatch,^eqef,
	(min_access_class specified on local and remote systems are isolated.)

ec   no_card_password,^pass,
	(Person_id specified does not have a card input password.)

ec   no_person_id,^id,
	(Person_id specified does not exist.)

ec   non_matching_ids,^mtchids,
	(Person_ids on local and remote systems do not match.)

ec   non_matching_passwords,^mtchpas,
	(Card input passwords on local and remote systems do not match.)

ec   non_matching_versions,^mtchvrs,
	(Remote system IMFT version does not match specification on local system.)

ec   not_synchronized,^sync,
	(Remote system is not sychronized with local system.)

ec   process_authorization_too_low,palow,
	(Maximum access class for data transfer is greater than process authorization.)

ec   reply_pending,rpypndg,
	(Reply to previous command pending.)

ec   timeout,timeout,
	(Attempt to read/write record timed out.)

ec   unknown_status_code,badcode,
	(Status code from remote system is not recognized by this driver.)

	end




		    imft_find_input_switch_.pl1     08/08/88  1543.2r w 08/08/88  1408.8       26244



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* Searches a list of I/O switches for the first one for which input is available: if there is no input, optionally block
   until some becomes available */

/* Created:  April 1982 by G. Palter */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */


imft_find_input_switch_:
     procedure (P_fis_info_ptr, P_block, P_switch, P_code);


/* Parameters */

dcl  P_fis_info_ptr pointer parameter;			/* -> the list of switche s */
dcl  P_block bit (1) aligned parameter;			/* ON => block if no input available */
dcl  P_switch fixed binary parameter;			/* set to index of switch with input (if any) */
dcl  P_code fixed binary (35) parameter;


/* Remaining declarations */

dcl  1 rsi aligned like tty_read_status_info;

dcl  1 ewi aligned like event_wait_info;

dcl  idx fixed binary;

dcl  error_table_$bad_arg fixed binary (35) external;
dcl  error_table_$unimplemented_version fixed binary (35) external;

dcl  convert_ipc_code_ entry (fixed binary (35));
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  ipc_$block entry (pointer, pointer, fixed binary (35));

dcl  addr builtin;

/**/

	fis_info_ptr = P_fis_info_ptr;

	if fis_info.version ^= FIS_INFO_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if fis_info.n_iocbs ^= fis_info.n_channels then do;
	     P_code = error_table_$bad_arg;
	     return;
	end;


/* Check the list for a switch with available input */

CHECK_FOR_INPUT:
	rsi.input_pending = "0"b;			/* some I/O modules don't clear this */

	do idx = 1 to fis_info.n_iocbs;

	     call iox_$control (fis_info.iocbs (idx), "read_status", addr (rsi), P_code);
	     if P_code ^= 0 then return;		/* can't check all the switches */

	     if rsi.input_pending then do;		/* found it */
		P_switch = idx;
		return;				/* ... code already zero from above call */
	     end;
	end;

	if ^P_block then do;			/* don't wait around */
	     P_switch = 0;				/* ... none found */
	     return;				/* ... code already zeroed by last call above */
	end;


/* Block until some input is available: after the wakeup it is necessary to check all the switches again as the I/O
   modules send wakeups under various conditions (input available, channel hungup, etc.) */

	call ipc_$block (addr (fis_info.wait_list), addr (ewi), P_code);
	if P_code ^= 0 then do;			/* block failed */
	     call convert_ipc_code_ (P_code);
	     return;
	end;

	go to CHECK_FOR_INPUT;			/* look again */

/**/

%include "_imft_fis_info";
%page;
%include event_wait_info;

%include tty_read_status_info;

     end imft_find_input_switch_;




		    imft_hasp_.pl1                  07/19/83  1226.8r w 07/19/83  1018.3      234585



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* I/O module to translate between IMFT logical records and HASP physical records */

/* Created:  January 1983 by Robert Coren using Gary Palter's hasp-only imft_io_ as a base */
/* Modified:  June 1983 by Robert Coren to requote attach options when building attach description */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */


imft_hasp_:
     procedure ();
	return;					/* not an entry */


/* Parameters */

dcl  P_iocb_ptr pointer parameter;			/* *: -> I/O switch being operated upon */
dcl  P_code fixed binary (35) parameter;

dcl  P_attach_options (*) character (*) varying parameter;	/* attach: attachment arguments */
dcl  P_loud_sw bit (1) parameter;			/* attach: ON => attachment errors should call com_err_ */

dcl  P_open_mode fixed binary parameter;		/* open: opening mode */
dcl  P_open_sw bit (1) parameter;			/* open: obsolete parameter */

dcl  P_record_length fixed binary (21) parameter;		/* read_record: set to # of characters read into buffer;
						   write_record: # of characters to transmit as logical record */

dcl  P_buffer_ptr pointer parameter;			/* read_record: -> area to place result of read */
dcl  P_buffer_max_lth fixed binary (21) parameter;	/* read_record: size of area in characters */

dcl  P_record_ptr pointer parameter;			/* write_record: -> record to be written */

dcl  P_order character (*) parameter;			/* control: name of control order to be performed */
dcl  P_info_ptr pointer parameter;			/* control: -> additional information required to execute the
						   control order */

dcl  P_new_modes character (*) parameter;		/* modes: new modes to be set */
dcl  P_old_modes character (*) parameter;		/* modes: set to modes in effect before change */


/* Local copies of parameters */

dcl  iocb_ptr pointer;
dcl  code fixed binary (35);
dcl  loud_sw bit (1) aligned;
dcl  open_mode fixed binary;


/* Remaining declarations */

dcl  system_area area aligned based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  arg_index fixed binary;				/* # of attach option being processed */


dcl  terminal_attach_desc character (512);
dcl  terminal_switch_name character (32);

dcl  module_type character (12);			/* "host_" or "workstation_" */

dcl  data_received fixed bin (21);
dcl  packed_length fixed bin (21);
dcl  unpacked_chars fixed bin (21);

dcl  logical_record_data character (logical_record_data_lth) unaligned based (logical_record_data_ptr);
dcl  logical_record_data_lth fixed binary (21);
dcl  logical_record_data_ptr pointer;

dcl  logical_record_data_bits_lth fixed binary (24);

dcl  amount_left fixed binary (21);
dcl  amount_sent fixed binary (24);			/* may hold bit counters */
dcl  amount_to_send fixed binary (21);
dcl  fb14uu fixed binary (14) unaligned unsigned;
dcl  data_bytes char (n_bytes) based;
dcl  n_bytes fixed bin (21);

dcl  ips_mask bit (36);

dcl  IMFT_HASP_ character (32) static options (constant) initial ("imft_hasp_");

dcl  N_BITS_PER_CHARACTER fixed binary static options (constant) initial (9);

/* format: off */
dcl (error_table_$action_not_performed,
     error_table_$bad_mode, error_table_$eof_record, error_table_$improper_data_format,
     error_table_$long_record, error_table_$not_attached,
     error_table_$not_closed, error_table_$not_detached, error_table_$not_open,
     error_table_$short_record, error_table_$unimplemented_version)
	fixed binary (35) external;

/* format: on */

dcl  com_err_ entry () options (variable);
dcl  continue_to_signal_ entry (fixed binary (35));
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$reset_ips_mask entry (bit (36), bit (36));
dcl  hcs_$set_ips_mask entry (bit (36), bit (36));
dcl  ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1));
dcl  iox_$attach_ioname entry (character (*), pointer, character (*), fixed binary (35));
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  iox_$close entry (pointer, fixed binary (35));
dcl  iox_$destroy_iocb entry (pointer, fixed binary (35));
dcl  iox_$detach_iocb entry (pointer, fixed binary (35));
dcl  iox_$err_no_operation entry () options (variable);
dcl  iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35));
dcl  iox_$propagate entry (pointer);
dcl  iox_$read_record entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35));
dcl  iox_$write_record entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  requote_string_ entry (char (*)) returns (char (*));

dcl  (any_other, cleanup) condition;

dcl  (addbitno, addcharno, addr, bin, bit, currentsize, divide, hbound, index, lbound, length, min, mod, null, rtrim,
     size, string, substr, unspec) builtin;

/**/

/* Description of a switch attached through this module */

dcl  1 iad aligned based (iad_ptr),
       2 attach_description character (1024) varying,	/* attach description for this I/O switch */
       2 open_description character (24) varying,		/* open description for this I/O switch */
       2 switch like switch_info,			/* defines the terminal switch */
       2 flags aligned,
         3 input_direction bit (1) unaligned,		/* ON => receives data from remote system */
         3 pad bit (35) unaligned;

dcl  iad_ptr pointer;


/* Description of a single terminal level I/O switch */

dcl  1 switch_info aligned based,
       2 terminal_iocb_ptr pointer,			/* -> IOCB for terminal level module */
       2 current_physical_record_type fixed binary,	/* type of record currently in buffer (if any) */
       2 current_physical_record_n_els fixed binary (24),	/* # of characters or bits in current record */
       2 current_physical_record_used fixed binary (24),	/* # of characters or bits already returned to caller */
       2 pad bit (36),
       2 tior,					/* terminal_io_record used for I/O */
         3 header like terminal_io_record.header,
         3 data character (IMFT_PHYSICAL_RECORD_LTH) unaligned;


/**/

/* Physical record structure used to transmit data and control information */

dcl  1 imft_physical_record aligned based (ipr_ptr),
       2 pad1 bit (11) unaligned,
       2 flags unaligned,
         3 binary bit (1) unaligned,			/* ON => binary data in record as 7-bit bytes */
         3 bolr bit (1) unaligned,			/* ON => this is first physical record of a logical record */
         3 eolr bit (1) unaligned,			/* ON => last physical record in logical record */
         3 pad3 bit (4) unaligned,
       2 n_els unaligned,				/* # of elements (characters or 7-bit bytes) */
         3 pad4 bit (2) unaligned,
         3 high_order bit (7) unaligned,
         3 pad5 bit (2) unaligned,
         3 low_order bit (7) unaligned,
       2 data character (IMFT_PHYSICAL_RECORD_DATA_LTH) unaligned;
						/* the actual data */


dcl  ipr_ptr pointer;

dcl  (
     IMFT_PHYSICAL_RECORD_LTH initial (180),		/* size of each physical record */
     IMFT_PHYSICAL_RECORD_DATA_LTH initial (176),		/* # of bytes of user's data in each record */
     IMFT_PHYSICAL_RECORD_DATA_BITS_LTH initial (1232)	/* # of bits of user's data in each record for binary data */
     ) fixed binary static options (constant);

/**/

/* Attach an I/O switch for file transfer */

imft_hasp_host_attach:
     entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code);

	module_type = "host_";
	go to ATTACH_COMMON;

imft_hasp_workstation_attach:
     entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code);

	module_type = "workstation_";

ATTACH_COMMON:
	iocb_ptr = P_iocb_ptr;
	loud_sw = P_loud_sw;
	code = 0;

	iad_ptr = null ();				/* avoid freeing garbage if I/O switch already attached */

	if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_detached;
	     if loud_sw then call com_err_ (P_code, IMFT_HASP_, "For switch ^a.", iocb_ptr -> iocb.name);
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup) call cleanup_attachment ((0));



	allocate iad in (system_area) set (iad_ptr);
	iad.switch.terminal_iocb_ptr = null ();		/* keeps cleanup handler happy */

	iad.attach_description = "";
	iad.open_description = "";


	do arg_index = lbound (P_attach_options, 1) to hbound (P_attach_options, 1);
	     iad.attach_description = iad.attach_description || " " || requote_string_ ((P_attach_options (arg_index)));
	end;

	if index (iocb_ptr -> iocb.name, ".input.") ^= 0 then iad.input_direction = "1"b;

	else if index (iocb_ptr -> iocb.name, ".output.") ^= 0 then iad.input_direction = "0"b;

	else call abort_attachment (0, "Swtich name ^a does not specify input or output", iocb_ptr -> iocb.name);

	terminal_switch_name = "hasp_" || substr (module_type, 1, 1) || "." || rtrim (iocb_ptr -> iocb.name);

	terminal_attach_desc = "hasp_" || rtrim (module_type) || iad.attach_description;
						/* note that iad.attach_description already has leading space */

	call iox_$attach_ioname (terminal_switch_name, iad.switch.terminal_iocb_ptr, terminal_attach_desc, code);
	if code ^= 0 then call abort_attachment (code, "Unable to attach channel via: ^a", terminal_attach_desc);

/* Initialize the terminal switch structure */

	iad.switch.current_physical_record_type = -1;
	iad.switch.current_physical_record_n_els = 0;
	iad.switch.current_physical_record_used = 0;

	iad.switch.tior.version = terminal_io_record_version_1;

	if module_type = "workstation_" then do;
	     if iad.input_direction then
		iad.switch.tior.device_type = READER_DEVICE;
	     else iad.switch.tior.device_type = PUNCH_DEVICE;
	end;

	else do;
	     if iad.input_direction then
		iad.switch.tior.device_type = PUNCH_DEVICE;
	     else iad.switch.tior.device_type = READER_DEVICE;
	end;

	iad.switch.tior.slew_type = SLEW_BY_COUNT;
	iad.switch.tior.slew_count = 1;

	string (iad.switch.tior.flags) = ""b;

	iad.switch.tior.element_size = N_BITS_PER_CHARACTER;
	iad.switch.tior.n_elements = IMFT_PHYSICAL_RECORD_LTH;

/* Mask and complete construction of the IOCB */

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = addr (iad.attach_description);
	iocb_ptr -> iocb.attach_data_ptr = iad_ptr;
	iocb_ptr -> iocb.open = imft_hasp_open;
	iocb_ptr -> iocb.detach_iocb = imft_hasp_detach;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

RETURN_FROM_ATTACH:
	P_code = code;
	return;

/**/

/* Open an I/O switch for file transfer */

imft_hasp_open:
     entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	open_mode = P_open_mode;

	if ^((iad.input_direction & (open_mode = Sequential_input))
	     | (^iad.input_direction & (open_mode = Sequential_output))) then do;
						/* opening mode and direction must agree */
	     P_code = error_table_$bad_mode;
	     return;
	end;

	call iox_$open (iad.switch.terminal_iocb_ptr, open_mode, "0"b, P_code);
	if P_code ^= 0 then return;

	iad.open_description = rtrim (iox_modes (open_mode));

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	if iad.input_direction then
	     iocb_ptr -> iocb.read_record = imft_hasp_read_record;
	else iocb_ptr -> iocb.write_record = imft_hasp_write_record;

	iocb_ptr -> iocb.control = imft_hasp_control;
	iocb_ptr -> iocb.modes = imft_hasp_modes;

	iocb_ptr -> iocb.close = imft_hasp_close;
	iocb_ptr -> iocb.detach_iocb = imft_hasp_detach;

	iocb_ptr -> iocb.open_descrip_ptr = addr (iad.open_description);
						/* it's now open */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = 0;
	return;

/**/

/* Close an I/O switch used for file transfer */

imft_hasp_close:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	code = 0;

	if iocb_ptr -> iocb.open_descrip_ptr = null () then do;
	     P_code = error_table_$not_open;
	     return;
	end;

	call iox_$close (iad.switch.terminal_iocb_ptr, code);
	if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0;

	ips_mask = ""b;

	on condition (cleanup) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.open_descrip_ptr = null ();

	iocb_ptr -> iocb.open = imft_hasp_open;
	iocb_ptr -> iocb.detach_iocb = imft_hasp_detach;

	iocb_ptr -> iocb.control, iocb_ptr -> iocb.modes, iocb_ptr -> iocb.read_record, iocb_ptr -> iocb.write_record =
	     iox_$err_no_operation;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = code;

	return;

/**/

/* Detach an I/O switch from file transfer */

imft_hasp_detach:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr;
	code = 0;

	if iocb_ptr -> iocb.attach_descrip_ptr = null () then do;
	     P_code = error_table_$not_attached;
	     return;
	end;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	call cleanup_attachment (code);

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = null ();	/* it's detached */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = code;				/* in case trouble freeing the channel */
	return;

/**/

/* Perform control operations on an I/O switch attached for file transfer */

imft_hasp_control:
     entry (P_iocb_ptr, P_order, P_info_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> attach_data_ptr;
	call iox_$control (iad.switch.terminal_iocb_ptr, P_order, P_info_ptr, P_code);
						/* just pass all orders on */
	return;

/**/

/* Change modes: no modes are supported */

imft_hasp_modes:
     entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	P_old_modes = "";				/* no modes are reflected to caller */

	if P_new_modes = "" then
	     P_code = 0;
	else P_code = error_table_$bad_mode;

	return;

/**/

/* Transmit a logical record to the remote system as multiple physical records */

imft_hasp_write_record:
     entry (P_iocb_ptr, P_record_ptr, P_record_length, P_code);

	iocb_ptr = P_iocb_ptr;
	ilr_ptr = P_record_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	logical_record_data_ptr = addr (imft_logical_record.contents);
	logical_record_data_lth = imft_logical_record.length;

	terminal_io_record_ptr = addr (iad.switch.tior);
	ipr_ptr = addr (terminal_io_record.data);

	unspec (imft_physical_record) = ""b;		/* start out clean */

/* logical record header is sent as a separate physical record, which is always binary */

	imft_physical_record.binary = "1"b;
	imft_physical_record.bolr = "1"b;
	imft_physical_record.eolr = (logical_record_data_lth = 0);

	call unpack (ilr_ptr, addr (imft_physical_record.data), length (unspec (imft_logical_record_header)),
	     unpacked_chars);

	imft_physical_record.n_els.low_order = bit (bin (unpacked_chars, 7), 7);
						/* this assumes that the length of the header will always fit in 7 bits */
	call transmit_physical_record (unpacked_chars, P_code);
	if P_code ^= 0 then return;

	imft_physical_record.bolr = "0"b;

/* Now send the rest of the data (if any), unpacking only if necessary */

	amount_sent = 0;


	if logical_record_data_lth ^= 0 then
	     if imft_logical_record.binary | imft_logical_record.eight_bit then do;

/* Binary data: unpack 7 bits at a time into 9 bit forming valid ASCII characters for transmission.  At some future time,
   support for binary transmission should be provided */

		logical_record_data_bits_lth = N_BITS_PER_CHARACTER * logical_record_data_lth;

		do while (amount_sent < logical_record_data_bits_lth);

		     imft_physical_record.binary = "1"b;

		     amount_left = logical_record_data_bits_lth - amount_sent;
		     amount_to_send = min (amount_left, IMFT_PHYSICAL_RECORD_DATA_BITS_LTH);
						/* are using 7 bits per character */

		     call unpack (addbitno (logical_record_data_ptr, amount_sent), addr (imft_physical_record.data),
			amount_to_send, unpacked_chars);

		     fb14uu = unpacked_chars;		/* put # of characters in record into the record */
		     imft_physical_record.n_els.high_order = substr (unspec (fb14uu), 1, 7);
		     imft_physical_record.n_els.low_order = substr (unspec (fb14uu), 8, 7);

		     if amount_to_send = amount_left then
						/* last physical record */
			imft_physical_record.eolr = "1"b;

		     call transmit_physical_record (unpacked_chars, P_code);
						/* zap! */
		     if P_code ^= 0 then return;

		     amount_sent = amount_sent + amount_to_send;
		end;
	     end;


	     else do;

/* Character only data */

		do while (amount_sent < logical_record_data_lth);

		     amount_left = logical_record_data_lth - amount_sent;
		     amount_to_send = min (amount_left, IMFT_PHYSICAL_RECORD_DATA_LTH);
						/* determine how much to send now */
		     imft_physical_record.data = substr (logical_record_data, (amount_sent + 1), amount_to_send);

		     fb14uu = amount_to_send;		/* put # of characters in record into the record */
		     imft_physical_record.n_els.high_order = substr (unspec (fb14uu), 1, 7);
		     imft_physical_record.n_els.low_order = substr (unspec (fb14uu), 8, 7);

		     if amount_to_send = amount_left then
						/* last physical record */
			imft_physical_record.eolr = "1"b;

		     call transmit_physical_record (amount_to_send, P_code);
						/* zap! */
		     if P_code ^= 0 then return;

		     amount_sent = amount_sent + amount_to_send;
		end;
	     end;

	return;

/**/

/* Receive the contents of a logical record from the remote system */

imft_hasp_read_record:
     entry (P_iocb_ptr, P_buffer_ptr, P_buffer_max_lth, P_record_length, P_code);

	iocb_ptr = P_iocb_ptr;
	ilr_ptr = P_buffer_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	terminal_io_record_ptr = addr (iad.switch.tior);
	ipr_ptr = addr (terminal_io_record.data);

/* read header record (which is always binary) */

	call receive_physical_record (n_bytes, P_code);
	if P_code ^= 0 then return;

	if ^imft_physical_record.bolr			/* not first in logical record? */
	then do;
	     P_code = error_table_$improper_data_format;
	     return;
	end;

	call pack (addr (imft_physical_record.data), ilr_ptr, n_bytes, packed_length);

	if imft_logical_record.version ^= IMFT_LOGICAL_RECORD_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if 4 * size (imft_logical_record_header) + imft_logical_record.length > P_buffer_max_lth
						/* record is too big to fit in caller's buffer */
	then do;
	     P_code = error_table_$long_record;
	     return;
	end;

/* now read the physical records (if any) that contain the data portion of the logical record */

	data_received = 0;
	unspec (imft_logical_record.contents) = ""b;	/* start clean */

	if imft_logical_record.binary | imft_logical_record.eight_bit then do;
	     logical_record_data_bits_lth = 9 * imft_logical_record.length;
						/* have to work in bits in this case */

	     do while (data_received < logical_record_data_bits_lth & ^imft_physical_record.eolr);
						/* should run out of data exactly when eolr goes on */

		call receive_physical_record (n_bytes, P_code);
		if P_code ^= 0 then return;

		call pack (addr (imft_physical_record.data),
		     addbitno (addr (imft_logical_record.contents), data_received), n_bytes, packed_length);
		data_received = data_received + packed_length;
	     end;

	     data_received = divide (data_received, 9, 21, 0);
						/* now convert to characters */
						/* note that real data ends on 9-bit boundary */
	end;

	else do while (data_received < imft_logical_record.length & ^imft_physical_record.eolr);
						/* these two conditions SHOULD be equivalent */
	     call receive_physical_record (n_bytes, P_code);
	     if P_code ^= 0 then return;

/* just copy the data directly */

	     addcharno (addr (imft_logical_record.contents), data_received) -> data_bytes =
		addr (imft_physical_record.data) -> data_bytes;
	     data_received = data_received + n_bytes;
	end;

	if data_received < imft_logical_record.length	/* premature end_of_record flag */
	then P_code = error_table_$eof_record;		/* it should probably be something else */

	else if ^imft_physical_record.eolr		/* used up length before finding end-of-record */
	then P_code = error_table_$long_record;		/* which means next record is probably messed up too */

	else P_code = 0;

	P_record_length = 4 * size (imft_logical_record_header) + data_received;
	return;

/**/

/* Cleanup whatever portion of an attachment exists */

cleanup_attachment:
     procedure (P_code);

dcl  P_code fixed binary (35) parameter;		/* a parameter to allow callers to ignore it */

	P_code = 0;

	if iad_ptr ^= null () then do;		/* there is an I/O switch */

	     if iad.switch.terminal_iocb_ptr ^= null () then do;
		call iox_$close (iad.switch.terminal_iocb_ptr, (0));
		call iox_$detach_iocb (iad.switch.terminal_iocb_ptr, P_code);
		call iox_$destroy_iocb (iad.switch.terminal_iocb_ptr, (0));
		iad.switch.terminal_iocb_ptr = null ();
	     end;

	     free iad in (system_area);
	     iad_ptr = null ();

	end;

	return;

     end cleanup_attachment;

/**/

/* Wrapper to protect against errors while IPS interrupts are masked */

any_other_handler:
     procedure () options (non_quick);

	if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask);
	ips_mask = ""b;

	call continue_to_signal_ ((0));		/* not interested, */

	return;

     end any_other_handler;



/* Abort a call to the attach entry:  print an error message if requested */

abort_attachment:
     procedure () options (variable, non_quick);

dcl  the_code fixed binary (35) based (the_code_ptr);
dcl  the_code_ptr pointer;

dcl  caller_message character (256);

	call cu_$arg_ptr (1, the_code_ptr, (0), (0));

	if loud_sw then do;				/* an error message is requested */
	     call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, (0), "1"b, "0"b);
	     call com_err_ (the_code, IMFT_HASP_, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message);
	end;

	call cleanup_attachment ((0));		/* get rid of anything that was accomplished */

	if the_code = 0 then
	     code = error_table_$action_not_performed;
	else code = the_code;			/* save the error code */

	go to RETURN_FROM_ATTACH;

     end abort_attachment;

/**/

/* transmits a single physical record */

transmit_physical_record:
     procedure (n_bytes, code);

dcl  n_bytes fixed bin (21);
dcl  code fixed binary (35);

	terminal_io_record.element_size = 9;
	terminal_io_record.n_elements = n_bytes + 4;	/* make sure they're still correct */
	terminal_io_record.version = terminal_io_record_version_1;

	call iox_$write_record (iad.switch.terminal_iocb_ptr, terminal_io_record_ptr,
	     (4 * currentsize (terminal_io_record)), code);

	unspec (imft_physical_record) = ""b;		/* start next record clean */

	return;

     end transmit_physical_record;

/**/

/* read a single physical HASP record */

receive_physical_record:
     procedure (bytes_read, code);

dcl  bytes_read fixed bin (21);
dcl  code fixed binary (35);

dcl  fb14uu fixed binary (14) unaligned unsigned;

	terminal_io_record.element_size = 9;
	terminal_io_record.n_elements = IMFT_PHYSICAL_RECORD_LTH;
	terminal_io_record.version = terminal_io_record_version_1;

	call iox_$read_record (iad.switch.terminal_iocb_ptr, terminal_io_record_ptr,
	     (4 * currentsize (terminal_io_record)), (0), code);
	if code = error_table_$short_record then code = 0;
	if code ^= 0 then return;

	unspec (fb14uu) = imft_physical_record.n_els.high_order || imft_physical_record.n_els.low_order;
	bytes_read = fb14uu;			/* record # of characters or bytes */

	return;

     end receive_physical_record;

/**/

/* pair of subroutines for converting between 7 bits/byte and 9 bits/byte */

pack_unpack:
     procedure;

	return;					/* not to be called */

dcl  packed_byte_ptr pointer parameter;
dcl  unpacked_byte_ptr pointer parameter;
dcl  P_input_chars fixed bin (21) parameter;
dcl  P_input_bits fixed bin (21) parameter;
dcl  P_output_chars fixed bin (21) parameter;
dcl  P_output_bits fixed bin (21) parameter;

dcl  unpacked_length fixed bin;
dcl  packed_bytes (unpacked_length) bit (7) unaligned based (packed_byte_ptr);
dcl  unpacked_bytes (unpacked_length) bit (9) unaligned based (unpacked_byte_ptr);

pack:
     entry (unpacked_byte_ptr, packed_byte_ptr, P_input_chars, P_output_bits);

/* input has 2 high-order bits of every 9 off, + 7 data bits; pack it into binary */

	unpacked_length = P_input_chars;
	P_output_bits = 7 * unpacked_length;
	packed_bytes = substr (unpacked_bytes, 3);	/* simple as that! */
	return;


unpack:
     entry (packed_byte_ptr, unpacked_byte_ptr, P_input_bits, P_output_chars);

/* input is binary; unpack it so that 2 high-order bits of every 9 are 0 */

	P_output_chars, unpacked_length = divide (P_input_bits + 6, 7, 21, 0);
	string (unpacked_bytes) = ""b;
	substr (unpacked_bytes, 3) = packed_bytes;	/* it works in this direction, too */
	return;

     end pack_unpack;

/**/

%include iocb;
%page;
%include iox_modes;
%page;
%include imft_logical_record;
%page;
%include terminal_io_record;

     end imft_hasp_;




		    imft_io_.pl1                    11/14/88  1517.9rew 11/14/88  1511.2      461907



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

/* I/O module to transmit files between Multics sites using I/O daemon record oriented communications modules */

/* Created:  October 1980 by G. Palter */
/* Modified: April 1982 by G. Palter to greatly simplify attach description and internal operation */
/* Modified: 26 July 1982 by G. Palter to add get_channel_names control order */
/* Modified: January 1983 by Robert Coren for communications independence */
/* Modified: June 1983 by Robert Coren to mask quits when calling iox_$write_record */
/* Modified: September 1983 by Robert Coren to hold quits during calls to iox_$write_record instead of masking them */
/* Modified: September 1983 by Robert Coren to pad the allocated record buffers by an extra word */

/****^  HISTORY COMMENTS:
  1) change(87-11-15,Oke), approve(88-08-01,MCR7948), audit(88-10-11,Farley),
     install(88-10-14,MR12.2-1165):
     Add support for "get_transport_line" and "put_transport_chars" control
     orders.
  2) change(88-11-10,Beattie), approve(88-08-01,PBF7948),
     audit(88-11-14,Farley), install(88-11-14,MR12.2-1214):
     Check records for negative length to prevent invalid data from the
     IO channel causing problems.  Remove check for bad version or data format
     if first read.  See note in receive_logical_control_record entry point.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */

imft_io_:
     procedure ();
	return;					/* not an entry */

/* Attach an I/O switch for file transfer */

imft_io_attach:
     entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code);

	iocb_ptr = P_iocb_ptr;
	loud_sw = P_loud_sw;
	code = 0;

	iad_ptr = null ();				/* avoid freeing garbage if I/O switch already attached */

	if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_detached;
	     if loud_sw then call com_err_ (P_code, IMFT_IO_, "For switch ^a.", iocb_ptr -> iocb.name);
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup) call cleanup_attachment (ignore_code);

	call create_ips_mask_ (addr (QUIT_NAME), 1, quit_mask);
						/* we'll need this to mask quits while writing */
	mask_quits = quit_mask;			/* but hcs_$set_ips_mask wants it unaligned */
						/* Process attachment options */

	if hbound (P_attach_options, 1) < 1 then
	     call abort_attachment (error_table_$noarg,
		"""-direction"", ""-input_description"", and ""-output_description"" must be supplied.");

	allocate iad in (system_area) set (iad_ptr);
	iad.input_switch.terminal_iocb_ptr,		/* keeps cleanup handler happy */
	     iad.output_switch.terminal_iocb_ptr, iad.input_switch.record_buffer_ptr,
	     iad.output_switch.record_buffer_ptr = null ();

	direction = "";				/* haven't seen -direction yet */
	input_description_idx = 0;			/* haven't seen -input_description yet */
	output_description_idx = 0;			/* haven't seen -output_description yet */
	io_description_idx = 0;			/* nor -io_description */
	iad.debug_mode = "0"b;			/* haven't seen -debug yet */
	iad.copy_data = "0"b;			/* haven't seen -copy_data yet */

	iad.attach_description = "";
	iad.open_description = "";


	do argument_idx = lbound (P_attach_options, 1) to hbound (P_attach_options, 1);

	     argument_ptr = addr (addr (P_attach_options (argument_idx)) -> string_overlay.characters (1));
	     argument_lth = length (P_attach_options (argument_idx));

	     if argument = "-direction" then do;
		direction = get_string_argument ();
		if (direction ^= "input") & (direction ^= "output") then
		     call abort_attachment (error_table_$bad_arg,
			"-direction must be followed by ""input"" or ""output""; not ""^a"".", direction);
	     end;

	     else if (argument = "-input_description") | (argument = "-ids") then do;
		an_attach_description = get_string_argument ();
		input_description_idx = argument_idx;
	     end;

	     else if (argument = "-output_description") | (argument = "-ods") then do;
		an_attach_description = get_string_argument ();
		output_description_idx = argument_idx;
	     end;

	     else if (argument = "-io_description") | (argument = "-iods") then do;
		an_attach_description = get_string_argument ();
		io_description_idx = argument_idx;
	     end;

	     else if argument = "-debug" then iad.debug_mode = "1"b;
	     else if argument = "-copy_data" then iad.copy_data = "1"b;

	     else call abort_attachment (error_table_$badopt, """^a""", argument);
	end;

	if direction = "" then call abort_attachment (error_table_$noarg, "-direction");

	if io_description_idx = 0 then do;
	     if input_description_idx = 0 then call abort_attachment (error_table_$noarg, "-input_description");

	     if output_description_idx = 0 then call abort_attachment (error_table_$noarg, "-output_description");
	end;
	else if input_description_idx ^= 0 | output_description_idx ^= 0 then
	     call abort_attachment (error_table_$inconsistent, "-io_description and -input_ or -output_description");

/* Construct our attach description */

	iad.attach_description = rtrim (IMFT_IO_);

	iad.attach_description = iad.attach_description || " -direction ";
	iad.attach_description = iad.attach_description || rtrim (direction);

	if io_description_idx ^= 0			/* single switch for both input and output */
	then do;
	     argument_ptr = addr (addr (P_attach_options (io_description_idx)) -> string_overlay.characters (1));
	     argument_lth = length (P_attach_options (io_description_idx));
	     iad.attach_description = iad.attach_description || " -io_description " || requote_string_ (argument);
	end;

	else do;
	     argument_ptr = addr (addr (P_attach_options (input_description_idx)) -> string_overlay.characters (1));
	     argument_lth = length (P_attach_options (input_description_idx));
	     iad.attach_description = iad.attach_description || " -input_description ";
	     iad.attach_description = iad.attach_description || requote_string_ (argument);

	     argument_ptr = addr (addr (P_attach_options (output_description_idx)) -> string_overlay.characters (1));
	     argument_lth = length (P_attach_options (output_description_idx));
	     iad.attach_description = iad.attach_description || " -output_description ";
	     iad.attach_description = iad.attach_description || requote_string_ (argument);
	end;

/* Attach through the terminal level */

	iad.input_direction = (direction = "input");

	terminal_attach_count = terminal_attach_count + 1;
	if terminal_attach_count > 999 then terminal_attach_count = 1;

	if io_description_idx ^= 0			/* only need to attach one switch */
	then do;
	     terminal_switch_name =
		rtrim (IMFT_IO_) || ".input_output."
		|| ltrim (convert (terminal_attach_count_pic, terminal_attach_count));
	     call iox_$attach_ioname (terminal_switch_name, terminal_iocb_ptr,
		"imft_" || P_attach_options (io_description_idx), code);
	     if code ^= 0 then
		call abort_attachment (code, "Unable to attach channel via: imft_^a",
		     P_attach_options (io_description_idx));

	     iad.input_switch.terminal_iocb_ptr, iad.output_switch.terminal_iocb_ptr = terminal_iocb_ptr;
	end;

	else do;					/* have to attach separate input and output switches */
	     terminal_switch_name =
		rtrim (IMFT_IO_) || ".input." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count));

	     call iox_$attach_ioname (terminal_switch_name, terminal_iocb_ptr,
		"imft_" || P_attach_options (input_description_idx), code);
	     if code ^= 0 then
		call abort_attachment (code, "Unable to attach input channel via: ^a",
		     P_attach_options (input_description_idx));

	     iad.input_switch.terminal_iocb_ptr = terminal_iocb_ptr;


	     terminal_switch_name =
		rtrim (IMFT_IO_) || ".output." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count));

	     call iox_$attach_ioname (terminal_switch_name, terminal_iocb_ptr,
		"imft_" || P_attach_options (output_description_idx), code);
	     if code ^= 0 then
		call abort_attachment (code, "Unable to attach output channel via: ^a",
		     P_attach_options (output_description_idx));

	     iad.output_switch.terminal_iocb_ptr = terminal_iocb_ptr;
	end;

	if iad.copy_data then do;
	     debug_switch_name = "imft.debug." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count));
	     call ioa_$rsnnl ("^a>^a.^[i^;o^]", debug_file_name, ignore_fb21, rtrim (get_wdir_ ()), debug_switch_name,
		iad.input_direction);
	     call iox_$attach_ioname (debug_switch_name, debug_iocb_ptr, "vfile_ " || debug_file_name || " -extend",
		code);
	     if code ^= 0 then call com_err_ (code, IMFT_IO_, "Trying to attach debug file.");
	end;

/* Initialize the input and output terminal switch structures */

	string (iad.input_switch.flags), string (iad.output_switch.flags) = ""b;
	iad.input_switch.data_length = 0;
	iad.input_switch.rest_of_record_ptr = null ();

/* allocate buffers for active records */
/* include an extra word of padding so that I/O modules that work in 8-bit bytes won't go off the end */

	imft_logical_record_length = IMFT_MAX_RECORD_LENGTH + 4;
	allocate imft_logical_record in (system_area) set (iad.input_switch.record_buffer_ptr);
	allocate imft_logical_record in (system_area) set (iad.output_switch.record_buffer_ptr);

	iad.abort_in_progress = "0"b;			/* didn't encounter any errors yet */
	iad.abort_code = 0;


/* Mask and complete construction of the IOCB */

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (MASK_OFF, ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = addr (iad.attach_description);
	iocb_ptr -> iocb.attach_data_ptr = iad_ptr;
	iocb_ptr -> iocb.open = imft_io_open;
	iocb_ptr -> iocb.detach_iocb = imft_io_detach;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

RETURN_FROM_ATTACH:
	P_code = code;
	return;
%page;

/* Open an I/O switch for file transfer */

imft_io_open:
     entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	open_mode = P_open_mode;

	if ^((iad.input_direction & (open_mode = Stream_input)) | (^iad.input_direction & (open_mode = Stream_output)))
	then do;					/* opening mode and direction must agree */
	     P_code = error_table_$bad_mode;
	     return;
	end;

	if iad.input_switch.terminal_iocb_ptr = iad.output_switch.terminal_iocb_ptr then do;
	     call iox_$open (iad.input_switch.terminal_iocb_ptr, Sequential_input_output, "0"b, P_code);
	     if P_code ^= 0 then return;
	end;

	else do;
	     call iox_$open (iad.input_switch.terminal_iocb_ptr, Sequential_input, "0"b, P_code);
	     if P_code ^= 0 then return;

	     call iox_$open (iad.output_switch.terminal_iocb_ptr, Sequential_output, "0"b, P_code);
	     if P_code ^= 0 then do;			/* must close the other one to stay happy */
		call iox_$close (iad.input_switch.terminal_iocb_ptr, ignore_code);
		return;
	     end;
	end;

	iad.input_switch.first_read = "1"b;		/* so we can know to throw out old garbage */
	call iox_$control (iad.output_switch.terminal_iocb_ptr, "resetwrite", null (), 0);

	iad.open_description = rtrim (iox_modes (open_mode));

	if iad.copy_data then call iox_$open (debug_iocb_ptr, Stream_output, "0"b, ignore_code);

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (MASK_OFF, ips_mask);

	if iad.input_direction then
	     iocb_ptr -> iocb.get_chars, iocb_ptr -> iocb.get_line = imft_io_get_chars;
	else iocb_ptr -> iocb.put_chars = imft_io_put_chars;

	iocb_ptr -> iocb.control = imft_io_control;
	iocb_ptr -> iocb.modes = imft_io_modes;

	iocb_ptr -> iocb.close = imft_io_close;
	iocb_ptr -> iocb.detach_iocb = imft_io_detach;

	iocb_ptr -> iocb.open_descrip_ptr = addr (iad.open_description);
						/* it's now open */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = 0;
	return;
%page;

/* Close an I/O switch used for file transfer */

imft_io_close:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	code = 0;

	if iocb_ptr -> iocb.open_descrip_ptr = null () then do;
	     P_code = error_table_$not_open;
	     return;
	end;

	if iad.input_switch.terminal_iocb_ptr = iad.output_switch.terminal_iocb_ptr then do;
	     call iox_$control (iad.input_switch.terminal_iocb_ptr, "abort", null (), 0);
						/* clean it out first */
	     call iox_$close (iad.input_switch.terminal_iocb_ptr, code);
	     if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0;
	end;

	else do;
	     call iox_$control (iad.output_switch.terminal_iocb_ptr, "abort", null (), 0);
	     call iox_$control (iad.input_switch.terminal_iocb_ptr, "abort", null (), 0);
						/* clean out both switches */

	     call iox_$close (iad.output_switch.terminal_iocb_ptr, code);
	     if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0;

	     call iox_$close (iad.input_switch.terminal_iocb_ptr, code);
	     if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0;
	end;

	if iad.copy_data then call iox_$close (debug_iocb_ptr, ignore_code);

	ips_mask = ""b;

	on condition (cleanup) call any_other_handler ();

	call hcs_$set_ips_mask (MASK_OFF, ips_mask);

	iocb_ptr -> iocb.open_descrip_ptr = null ();

	iocb_ptr -> iocb.open = imft_io_open;
	iocb_ptr -> iocb.detach_iocb = imft_io_detach;

	iocb_ptr -> iocb.control, iocb_ptr -> iocb.modes, iocb_ptr -> iocb.get_chars, iocb_ptr -> iocb.get_line,
	     iocb_ptr -> iocb.put_chars = iox_$err_no_operation;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = code;

	return;
%page;

/* Detach an I/O switch from file transfer */

imft_io_detach:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr;
	code = 0;

	if iocb_ptr -> iocb.attach_descrip_ptr = null () then do;
	     P_code = error_table_$not_attached;
	     return;
	end;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	call cleanup_attachment (code);

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (MASK_OFF, ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = null ();	/* it's detached */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = code;				/* in case trouble freeing the channel */
	return;
%page;

/* Write data records to the remote Multics: formats the user's data stream into IMFT logical records and
   transmits them to the remote Multics.  If any errors are detected while
   writing, this I/O module signals the "imft_write_abort_" condition which imft_transmit_object_ handles through the
   "get_abort_info" control order */

imft_io_put_chars:
     entry (P_iocb_ptr, P_data_ptr, P_data_lth, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	code = 0;

	if iad.input_direction then do;		/* can't write the input side of a pipe */
	     P_code = error_table_$invalid_write;
	     return;
	end;

	total_data = P_data_lth;
	data_ptr = P_data_ptr;
	data_sent = 0;

	do while (data_sent < total_data);
	     chars_to_send = min (IMFT_MAX_RECORD_LENGTH, total_data - data_sent);
	     call transmit_logical_data_record (IMFT_DATA, data_ptr, chars_to_send);
						/* does the actual work */

	     data_sent = data_sent + chars_to_send;
	     data_ptr = addcharno (data_ptr, chars_to_send);
	end;

	P_code = code;
	return;
%page;

/* Read data records from the remote Multics:  reads requested number of data characters from the remote system.
   Data is read until either the user's buffer is filled or a control record is encountered.  If a control record is read
   before any data is found or an I/O error occurs during a read, the condition "imft_read_abort_" is signalled which is
   recognized by the caller.  The reason for the termination of the read request can be determined by the "get_abort_info"
   control order.
   If the last whole record read won't fit in the caller's buffer, the remainder is
   held in record_buffer, and input_switch.rest_of_record_ptr points to it.
*/

imft_io_get_chars:
     entry (P_iocb_ptr, P_buffer_ptr, P_buffer_max_length, P_data_lth, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	if ^iad.input_direction then do;		/* attempt to read the "punch" */
	     P_code = error_table_$invalid_read;
	     return;
	end;

	if iad.input_switch.control_record_present then call abort_read_operation (NO_ERROR);

	buffer_used = 0;
	buffer_max_length = P_buffer_max_length;
	continue = "1"b;

	do while (buffer_used < buffer_max_length & continue);
	     if iad.input_switch.data_present		/* data left over from previous read */
	     then do;
		chars_to_copy = min (iad.input_switch.data_length, buffer_max_length - buffer_used);
		substr (caller_buffer, buffer_used + 1, chars_to_copy) = substr (rest_of_record, 1, chars_to_copy);
		buffer_used = buffer_used + chars_to_copy;
		iad.input_switch.data_length = iad.input_switch.data_length - chars_to_copy;
		if iad.input_switch.data_length > 0 then
		     iad.input_switch.rest_of_record_ptr =
			addcharno (iad.input_switch.rest_of_record_ptr, chars_to_copy);
		else iad.input_switch.data_present = "0"b;
	     end;

	     if buffer_used < buffer_max_length		/* haven't filled caller's buffer yet */
	     then do;
		ilr_ptr = iad.input_switch.record_buffer_ptr;
		imft_logical_record.version = IMFT_LOGICAL_RECORD_VERSION_1;
		call iox_$read_record (iad.input_switch.terminal_iocb_ptr, ilr_ptr,
		     4 * size (imft_logical_record_header) + IMFT_MAX_RECORD_LENGTH, record_length, code);
		if code = error_table_$short_record then code = 0;
						/* "short" records are perfectly OK */
		if code ^= 0 then call abort_read_operation (code);

		if iad.copy_data then do;
		     call iox_$put_chars (debug_iocb_ptr, addr (MARKER), length (MARKER), ignore_code);
		     call iox_$put_chars (debug_iocb_ptr, ilr_ptr, record_length, ignore_code);
		end;

		if imft_logical_record.type ^= IMFT_DATA/* oops, this is a control record */
		then do;				/* save it be read by the appropriate control operation */
		     iad.input_switch.data_present = "0"b;
		     iad.input_switch.control_record_present = "1"b;
						/* for the use of the next read of either type */
		     iad.input_switch.data_length = record_length;
						/* next read_control_record can just scoop it out */
		     iad.input_switch.rest_of_record_ptr = ilr_ptr;
		     continue = "0"b;		/* but mustn't read any more right now */

		     if buffer_used = 0		/* there was no data to return */
			then
			call abort_read_operation (NO_ERROR);


		end;

		else do;				/* it's data, just as we hoped */
		     chars_to_copy = min (imft_logical_record.length, buffer_max_length - buffer_used);
		     substr (caller_buffer, buffer_used + 1, chars_to_copy) =
			substr (imft_logical_record.contents, 1, chars_to_copy);
		     buffer_used = buffer_used + chars_to_copy;
		     if chars_to_copy < imft_logical_record.length
						/* couldn't take it all */
		     then do;
			iad.input_switch.data_present = "1"b;
						/* save it for next time */
			iad.input_switch.data_length = imft_logical_record.length - chars_to_copy;
			iad.input_switch.rest_of_record_ptr =
			     addcharno (addr (imft_logical_record.contents), chars_to_copy);
		     end;
		     else iad.input_switch.data_present = "0"b;
		end;
	     end;
	end;

	P_data_lth = buffer_used;
	P_code = 0;				/* here iff successful */
	return;
%page;

/* Perform control operations on an I/O switch attached for file transfer */

imft_io_control:
     entry (P_iocb_ptr, P_order, P_info_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	order = P_order;
	info_ptr = P_info_ptr;

	code = 0;


	if order = "write_command_record" then do;

/* Write a command record:  Commands are sent by an output driver to the remote system's input driver to instruct the
   input driver as to what it should do next (begin reception of an object, abort, synchronize, etc.) */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version;

	     else if iad.input_direction then		/* must be transmitting data */
		code = error_table_$invalid_write;

	     else do;
		icri_ptr = info_ptr;
		if icri.timeout > 0 then do;		/* trap no response */
		     call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout);
		     on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
		end;
		call transmit_logical_control_record ((icri.record_type), icri.record_ptr, icri.record_lth, code);
		call timer_manager_$reset_alarm_call (read_write_timeout);
	     end;
	end;


	else if order = "read_command_record" then do;

/* Read a command record: any intervening data records are discarded */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version;

	     else if ^iad.input_direction then		/* must be receiving data to receive control records */
		code = error_table_$invalid_read;

	     else do;
		icri_ptr = info_ptr;
		if icri.timeout > 0 then do;		/* trap no response */
		     call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout);
		     on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
		end;
		call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth,
		     icri.record_type, code);
		call timer_manager_$reset_alarm_call (read_write_timeout);
	     end;
	end;


	else if order = "write_reply_record" then do;

/* Write a reply record:  Reply records are often sent by an input driver in response to a command record and indicate the
   input driver's reasons for accepting or rejecting a command */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version;

	     else if ^iad.input_direction then		/* must be receive side of a connection */
		code = error_table_$invalid_write;

	     else do;
		icri_ptr = info_ptr;
		if icri.timeout > 0 then do;		/* trap no response */
		     call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout);
		     on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
		end;
		call transmit_logical_control_record ((icri.record_type), icri.record_ptr, icri.record_lth, code);
		call timer_manager_$reset_alarm_call (read_write_timeout);
	     end;
	end;


	else if order = "read_reply_record" then do;

/* Read a reply record */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version;

	     else if iad.input_direction then		/* must be transmitting side of connection */
		code = error_table_$invalid_read;

	     else do;
		icri_ptr = info_ptr;
		if icri.timeout > 0 then do;		/* trap no response */
		     call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout);
		     on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
		end;
		call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth,
		     icri.record_type, code);
		call timer_manager_$reset_alarm_call (read_write_timeout);
	     end;
	end;


	else if order = "get_abort_info" then do;

/* Return cause of previous get_chars or put_chars failure */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version;

	     else do;
		icri_ptr = info_ptr;

		if iad.abort_in_progress then do;	/* something did indeed go wrong */
		     iad.abort_in_progress = "0"b;

		     if (iad.abort_code ^= 0) & (iad.abort_code ^= imft_et_$reply_pending) then do;
						/* I/O error during read/write */
			icri.record_type = IMFT_ABORT;
			abort_command_ptr = icri.record_ptr;
			abort_command.reason = IMFT_ABORT_LOCAL_IO_ERROR;
			abort_command.code = iad.abort_code;
			icri.record_lth = 4 * currentsize (abort_command);
		     end;				/* let caller see exact error */

		     else do;			/* encountered a control record: return it */
			call timer_manager_$alarm_call (ONE_MINUTE, RELATIVE_SECONDS, read_write_timeout);
			on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
			call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth,
			     icri.record_type, code);
			call timer_manager_$reset_alarm_call (read_write_timeout);
		     end;
		end;

		else code = error_table_$no_operation;	/* no abort was happening */
	     end;
	end;


	else if order = "get_channel_names" then do;

/* Return the names of the channels attached through this switch */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> get_channel_names.version ^= GET_CHANNEL_NAMES_VERSION_1 then
		code = error_table_$unimplemented_version;

	     else do;
		get_channel_names_ptr = info_ptr;
		local_tgci.version = tty_get_channel_info_version;

		call iox_$control (iad.input_switch.terminal_iocb_ptr, "get_channel_info", addr (local_tgci), code);

		if code = 0 then do;		/* got the input channel ... */
		     get_channel_names.input_channel = local_tgci.channel_name;
		     call iox_$control (iad.output_switch.terminal_iocb_ptr, "get_channel_info", addr (local_tgci),
			code);
		     if code = 0 then		/* ... and got the output channel */
			get_channel_names.output_channel = local_tgci.channel_name;
		end;

		if code ^= 0 then			/* couldn't get one of the channel names */
		     if code = error_table_$undefined_order_request then code = imft_et_$cant_get_channel_names;
	     end;
	end;


	else if (order = "read_status") | (order = "resetread") then
	     call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code);
						/* always apply these to the input connection */

	else if (order = "write_status") | (order = "resetwrite") | (order = "runout") then
	     call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code);
						/* always apply these to the output connection */

	else if order = "abort" then do;		/* always apply this to both switches */
	     call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code);
	     if iad.input_switch.terminal_iocb_ptr ^= iad.output_switch.terminal_iocb_ptr then
		call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code);
	end;


/* Handle handshaking IO for connection protocol. */

	else if order = "get_transport_line" then do;
	     icri_ptr = info_ptr;
	     if icri.timeout > 0 then do;		/* trap no response */
		on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
		call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout);
	     end;

	     if iad.input_switch.terminal_iocb_ptr ^= null () then
		call iox_$get_line (iad.input_switch.terminal_iocb_ptr, icri.record_ptr, icri.record_max_lth,
		     icri.record_lth, code);
	     else call iox_$get_line (iad.output_switch.terminal_iocb_ptr, icri.record_ptr, icri.record_max_lth,
		     icri.record_lth, code);

	     if icri.timeout > 0 then do;
		call timer_manager_$reset_alarm_call (read_write_timeout);
		revert condition (cleanup);
	     end;
	end;

	else if order = "put_transport_chars" then do;
	     icri_ptr = info_ptr;
	     if icri.timeout > 0 then do;		/* trap no response */
		on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
		call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout);
	     end;

	     if iad.input_switch.terminal_iocb_ptr ^= null () then
		call iox_$put_chars (iad.input_switch.terminal_iocb_ptr, icri.record_ptr, icri.record_lth, code);
	     else call iox_$put_chars (iad.output_switch.terminal_iocb_ptr, icri.record_ptr, icri.record_lth, code);

	     if icri.timeout > 0 then do;
		call timer_manager_$reset_alarm_call (read_write_timeout);
		revert condition (cleanup);
	     end;
	end;

	else do;					/* pass others on to the appropriate half of the connection */
	     if iad.input_direction then
		call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code);
	     else call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code);
	end;

RETURN_FROM_IMFT_CONTROL:
	P_code = code;

	return;
%page;

/* Internal procedure which is invoked when a read/write of a command/reply record times out */

read_write_timeout:
     procedure ();

	code = imft_et_$timeout;

	if iad.debug_mode then			/* give the programmer a chance when debugging */
	     signal condition (imft_debug_);

	go to RETURN_FROM_IMFT_CONTROL;


     end read_write_timeout;

/**/

/* Change modes: no modes are supported */

imft_io_modes:
     entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	P_old_modes = "";				/* no modes are reflected to caller */

	if P_new_modes = "" then
	     P_code = 0;
	else P_code = error_table_$bad_mode;

	return;
%page;

/* Cleanup whatever portion of an attachment exists */

cleanup_attachment:
     procedure (P_code);

dcl  P_code fixed binary (35) parameter;		/* a parameter to allow callers to ignore it */

	P_code = 0;

	if iad_ptr ^= null () then do;		/* there is an I/O switch */

	     if iad.input_switch.terminal_iocb_ptr ^= null () then do;
		call iox_$close (iad.input_switch.terminal_iocb_ptr, ignore_code);
		call iox_$detach_iocb (iad.input_switch.terminal_iocb_ptr, P_code);
		call iox_$destroy_iocb (iad.input_switch.terminal_iocb_ptr, ignore_code);
		iad.input_switch.terminal_iocb_ptr = null ();
	     end;

	     if iad.output_switch.terminal_iocb_ptr ^= null () then do;
		call iox_$close (iad.output_switch.terminal_iocb_ptr, ignore_code);
		call iox_$detach_iocb (iad.output_switch.terminal_iocb_ptr, P_code);
		call iox_$destroy_iocb (iad.output_switch.terminal_iocb_ptr, ignore_code);
		iad.output_switch.terminal_iocb_ptr = null ();
	     end;

	     if iad.input_switch.record_buffer_ptr ^= null () then do;
		free iad.input_switch.record_buffer_ptr -> imft_logical_record in (system_area);
		iad.input_switch.record_buffer_ptr = null ();
	     end;

	     if iad.output_switch.record_buffer_ptr ^= null () then do;
		free iad.output_switch.record_buffer_ptr -> imft_logical_record in (system_area);
		iad.output_switch.record_buffer_ptr = null ();
	     end;

	     if debug_iocb_ptr ^= null () then do;
		call iox_$close (debug_iocb_ptr, ignore_code);
		call iox_$detach_iocb (debug_iocb_ptr, ignore_code);
		call iox_$destroy_iocb (debug_iocb_ptr, ignore_code);
		debug_iocb_ptr = null ();
	     end;

	     free iad in (system_area);
	     iad_ptr = null ();

	end;

	return;

     end cleanup_attachment;
%page;

/* Wrapper to protect against errors while IPS interrupts are masked */

any_other_handler:
     procedure () options (non_quick);

	if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask);
	ips_mask = ""b;

	call continue_to_signal_ (ignore_code);		/* not interested, */

	return;

     end any_other_handler;



/* Abort a call to the attach entry:  print an error message if requested */

abort_attachment:
     procedure () options (variable, non_quick);

dcl  the_code fixed binary (35) based (the_code_ptr);
dcl  the_code_ptr pointer;

dcl  caller_message character (256);

	call cu_$arg_ptr (1, the_code_ptr, ignore_fb21, ignore_code);

	if loud_sw then do;				/* an error message is requested */
	     call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, ignore_fb21, "1"b, "0"b);
	     call com_err_ (the_code, IMFT_IO_, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message);
	end;

	call cleanup_attachment (ignore_code);		/* get rid of anything that was accomplished */

	if the_code = 0 then
	     code = error_table_$action_not_performed;
	else code = the_code;			/* save the error code */

	go to RETURN_FROM_ATTACH;

     end abort_attachment;
%page;

/* Invoked if an error arises during get_chars operation */


abort_read_operation:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	iad.abort_in_progress = "1"b;
	iad.abort_code = p_code;
SIGNAL_RECEIVE_FAILURE_FOREVER:
	signal condition (imft_read_abort_);
	go to SIGNAL_RECEIVE_FAILURE_FOREVER;

     end abort_read_operation;
%page;

/* Fetch the next argument from the attach options and validate that it is a non-null character string */

get_string_argument:
     procedure () returns (character (*));

dcl  option_name character (32);

	option_name = argument;			/* about to move on to the next one */

	if argument_idx = hbound (P_attach_options, 1) then
	     call abort_attachment (error_table_$noarg, "Character string following ""^a"".", option_name);

	argument_idx = argument_idx + 1;

	argument_ptr = addr (addr (P_attach_options (argument_idx)) -> string_overlay.characters (1));
	argument_lth = length (P_attach_options (argument_idx));

	if argument = "" then
	     call abort_attachment (0, "Character string following ""^a"" must be non-null.", option_name);

	return (argument);

     end get_string_argument;
%page;

/* Transmit a logical record to the remote system */

transmit_logical_record:
     procedure ();

	return;					/* not an entry */


/* Parameters */

dcl  P_logical_record_type fixed binary (7) unaligned unsigned parameter;
						/* type of record being transmitted */
dcl  P_logical_record_data_ptr pointer parameter;		/* -> the logical record */
dcl  P_logical_record_data_lth fixed binary (21) parameter; /* length of logical record in characters */

dcl  P_code fixed binary (35) parameter;		/* control: status code */


/* Remaining declarations */

dcl  logical_record_data character (logical_record_data_lth) unaligned based (logical_record_data_ptr);
dcl  logical_record_data_lth fixed binary (21);
dcl  logical_record_data_ptr pointer;

dcl  1 trsi aligned like tty_read_status_info automatic;
dcl  1 auto_event_info aligned like event_wait_info;

dcl  1 write_status_info aligned,
       2 event_channel fixed bin (71),
       2 output_pending bit (1);

dcl  put_chars_operation bit (1) aligned;		/* ON => iox_$put_chars (data records) */

dcl  quit_pending bit (1);


/* Transmit a data record: aborts by signalling imft_write_abort_ if an I/O error is encountered */

transmit_logical_data_record:
     entry (P_logical_record_type, P_logical_record_data_ptr, P_logical_record_data_lth);

	put_chars_operation = "1"b;
	go to TRANSMIT_COMMON;


/* Transmit a control record: any errors are reflected to the caller */

transmit_logical_control_record:
     entry (P_logical_record_type, P_logical_record_data_ptr, P_logical_record_data_lth, P_code);

	P_code = 0;
	put_chars_operation = "0"b;


TRANSMIT_COMMON:
	if ^iad.input_direction then do;		/* output side: check for unexpected replies */
	     trsi.input_pending = "0"b;		/* ... in case the next call fails */
	     call iox_$control (iad.input_switch.terminal_iocb_ptr, "read_status", addr (trsi), ignore_code);
	     if trsi.input_pending then call abort_write_operation (imft_et_$reply_pending);
	end;

	ilr_ptr = iad.output_switch.record_buffer_ptr;
	logical_record_data_ptr = P_logical_record_data_ptr;
	logical_record_data_lth, imft_logical_record.length = P_logical_record_data_lth;

	imft_logical_record.version = IMFT_LOGICAL_RECORD_VERSION_1;
	imft_logical_record.type = P_logical_record_type;
	string (imft_logical_record.flags) = "0"b;
	if logical_record_data_lth > 0 then do;
	     if verify (logical_record_data, substr (collate9 (), 1, 256)) ^= 0
						/* there's some data with 9th bit on */
		then
		imft_logical_record.binary = "1"b;
	     else if verify (logical_record_data, collate ()) ^= 0
						/* no 9-bit, but some 8-bit data */
		then
		imft_logical_record.eight_bit = "1"b;
	     imft_logical_record.contents = logical_record_data;
	end;

/* in order to make sure the record isn't interrupted by a control record as a result of
   a QUIT followed by an operator command, intercept quits while writing the record,
   and signal them once we're done */

	quit_pending = "0"b;
	on condition (quit)
	     begin;
	     quit_pending = "1"b;
	end;

	call iox_$write_record (iad.output_switch.terminal_iocb_ptr, ilr_ptr,
	     4 * size (imft_logical_record_header) + imft_logical_record.length, code);

	revert condition (quit);

	if code ^= 0 then call abort_write_operation (code);

	if quit_pending then do;
	     call iox_$control (iad.output_switch.terminal_iocb_ptr, "write_status", addr (write_status_info), code);

/* try to ensure that the record has really made it out of ring 0 */

	     do while ((code = 0) & write_status_info.output_pending);
		event_wait_channel.channel_id = write_status_info.event_channel;
		call ipc_$block (addr (event_wait_channel), addr (auto_event_info), code);
		if code = 0 then
		     call iox_$control (iad.output_switch.terminal_iocb_ptr, "write_status", addr (write_status_info),
			code);
	     end;

	     signal condition (quit);
	end;

	if iad.copy_data then do;
	     call iox_$put_chars (debug_iocb_ptr, addr (MARKER), length (MARKER), ignore_code);
	     call iox_$put_chars (debug_iocb_ptr, ilr_ptr,
		4 * size (imft_logical_record_header) + imft_logical_record.length, ignore_code);
	end;


	if ^put_chars_operation then			/* here iff all written OK */
	     P_code = 0;

RETURN_FROM_TRANSMIT_LOGICAL_RECORD:
	return;



/* Internal to transmit_logical_record: aborts the current write operation */

abort_write_operation:
	procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	     if put_chars_operation then do;		/* data stream: abort the operation completely */
		iad.abort_in_progress = "1"b;
		iad.abort_code = p_code;
SIGNAL_TRANSMISSION_FAILURE_FOREVER:
		signal condition (imft_write_abort_);
		go to SIGNAL_TRANSMISSION_FAILURE_FOREVER;
	     end;					/* imft_transmit_object_ shouldn't return */

	     else do;				/* writing a control record: reflect error to caller */
		P_code = p_code;
		go to RETURN_FROM_TRANSMIT_LOGICAL_RECORD;
	     end;

	end abort_write_operation;

     end transmit_logical_record;
%page;

/* Receive the contents of a logical record from the remote system */

receive_logical_record:
     procedure ();

	return;					/* not an entry */

dcl  P_buffer_ptr pointer parameter;			/* -> buffer to place record contents */
dcl  P_buffer_max_length fixed binary (21) parameter;	/* maximum size of buffer (in characters) */
dcl  P_buffer_used fixed binary (21) parameter;		/* # of characters placed into buffer */

dcl  P_record_type fixed binary parameter;		/* control: set to type of control record found */
dcl  P_code fixed binary (35) parameter;		/* control: status cod */


/* Remaining declarations */

dcl  buffer_max_length fixed binary (21);
dcl  buffer_ptr pointer;
dcl  caller_buffer char (buffer_max_length) based (buffer_ptr);

dcl  found bit (1);

/* Receive a control record: flushes all data records until a control record is found and returned */

receive_logical_control_record:
     entry (P_buffer_ptr, P_buffer_max_length, P_buffer_used, P_record_type, P_code);

	P_record_type = -1;				/* haven't found it yet */
	P_code = 0;

	buffer_ptr = P_buffer_ptr;
	buffer_max_length = P_buffer_max_length;


	found = "0"b;
	iad.input_switch.data_present = "0"b;		/* if it was, we're ignoring it */
	if iad.input_switch.control_record_present then
	     ilr_ptr = iad.input_switch.rest_of_record_ptr;
	else do;
	     ilr_ptr = iad.input_switch.record_buffer_ptr;
	     imft_logical_record.version = IMFT_LOGICAL_RECORD_VERSION_1;

	     do while (^found);			/* keep reading until we find a control record */
		call iox_$read_record (iad.input_switch.terminal_iocb_ptr, ilr_ptr,
		     4 * size (imft_logical_record_header) + IMFT_MAX_RECORD_LENGTH, record_length, code);
		if code = error_table_$short_record then code = 0;
						/* short_record is not interesting */
		if code ^= 0 then do;

/****^
     Code here used to ignore codes error_table_$unimplemented_version and
     error_table_$improper_data_format on first read but this can leave both
     ends of a link waiting for the other to respond if garbage is received
     which is not good in production mode.  At least imft_driver_$init will
     display the code and return and iodd_ will indicate that driver could
     not be initialized.  These can be dealt with automatically.  Previous
     code required manual intervention by site personnel to get drivers to
     try again.
*/

		     P_code = code;
		     return;
		end;
		else do;
		     if iad.copy_data then do;
			call iox_$put_chars (debug_iocb_ptr, addr (MARKER), length (MARKER), ignore_code);
			call iox_$put_chars (debug_iocb_ptr, ilr_ptr, record_length, ignore_code);
		     end;

		     iad.input_switch.first_read = "0"b;
		     if imft_logical_record.type ^= IMFT_DATA
						/* it IS  a control record */
			then
			found = "1"b;
		end;
	     end;
	end;

	if imft_logical_record.length < 0 | imft_logical_record.length > buffer_max_length then
						/* an overlong control record!? */
	     P_code = error_table_$invalid_record_length;

	else do;
	     substr (caller_buffer, 1, imft_logical_record.length) = imft_logical_record.contents;
	     P_buffer_used = imft_logical_record.length;
	     P_record_type = imft_logical_record.type;
	     P_code = 0;
	end;

	iad.input_switch.control_record_present = "0"b;
	return;

     end receive_logical_record;
%page;

/* Parameters */

dcl  P_iocb_ptr pointer parameter;			/* *: -> I/O switch being operated upon */
dcl  P_code fixed binary (35) parameter;

dcl  P_attach_options (*) character (*) varying parameter;	/* attach: attachment arguments */
dcl  P_loud_sw bit (1) parameter;			/* attach: ON => attachment errors should call com_err_ */

dcl  P_open_mode fixed binary parameter;		/* open: opening mode */
dcl  P_open_sw bit (1) parameter;			/* open: obsolete parameter */

dcl  P_data_lth fixed binary (21) parameter;		/* get_*: set to # of characters read into buffer;
						   put_chars: # of characters to transmit as logical record */

dcl  P_buffer_ptr pointer parameter;			/* get_*: -> area to place result of read */
dcl  P_buffer_max_length fixed binary (21) parameter;	/* get_*: size of area in characters */

dcl  P_data_ptr pointer parameter;			/* put_chars: -> data stream to be written */

dcl  P_order character (*) parameter;			/* control: name of control order to be performed */
dcl  P_info_ptr pointer parameter;			/* control: -> additional information required to execute the
						   control order */

dcl  P_new_modes character (*) parameter;		/* modes: new modes to be set */
dcl  P_old_modes character (*) parameter;		/* modes: set to modes in effect before change */


/* Local copies of parameters */

dcl  iocb_ptr pointer;
dcl  code fixed binary (35);
dcl  ignore_code fixed binary (35);
dcl  ignore_fb21 fixed binary (21);

dcl  argument character (argument_lth) based (argument_ptr);/* based on attach options */
dcl  argument_lth fixed binary (21);
dcl  argument_ptr pointer;

dcl  loud_sw bit (1) aligned;

dcl  open_mode fixed binary;

dcl  order character (32);
dcl  info_ptr pointer;


/* Remaining declarations */

dcl  1 local_tgci aligned like tty_get_channel_info;	/* for get_channel_names */

dcl  system_area area aligned based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  argument_idx fixed binary;			/* # of attach option being processed */

dcl  direction character (32);
dcl  (input_description_idx, output_description_idx) fixed binary;
dcl  io_description_idx fixed binary;

dcl  an_attach_description character (512);

dcl  terminal_switch_name character (32);
dcl  terminal_iocb_ptr pointer;
dcl  terminal_attach_count fixed binary static initial (0);
dcl  terminal_attach_count_pic picture "999";

dcl  ips_mask bit (36);
dcl  quit_mask bit (36) aligned;

dcl  buffer_used fixed bin (21);
dcl  buffer_max_length fixed bin (21);
dcl  continue bit (1);
dcl  record_length fixed bin (21);
dcl  chars_to_copy fixed bin (21);
dcl  total_data fixed bin (21);
dcl  data_sent fixed bin (21);
dcl  chars_to_send fixed bin (21);
dcl  data_ptr pointer;

dcl  IMFT_IO_ character (32) static options (constant) initial ("imft_io_");

dcl  RELATIVE_SECONDS bit (2) static options (constant) initial ("11"b);
dcl  ONE_MINUTE fixed binary (71) static options (constant) initial (60);
dcl  MARKER character (4) static options (constant) initial ("REC:");
dcl  MASK_OFF bit (36) initial ((36)"0"b) internal static options (constant);
dcl  NO_ERROR fixed binary (35) initial (0) internal static options (constant);
dcl  QUIT_NAME (1) char (32) aligned internal static options (constant) initial ("quit");

dcl  mask_quits bit (36) internal static;		/* IPS mask to prevent quits */

dcl  debug_switch_name character (32);
dcl  debug_file_name character (168);
dcl  debug_iocb_ptr pointer internal static init (null ());

dcl  caller_buffer char (buffer_max_length) based (P_buffer_ptr);

/* structure for obtaining the address of the string portion of a varying character string */

dcl  1 string_overlay aligned based,
       2 lth fixed binary (21),
       2 characters (0 refer (string_overlay.lth)) character (1) unaligned;

/* format: off */
dcl (error_table_$action_not_performed, error_table_$badopt, error_table_$bad_arg,
     error_table_$bad_mode, error_table_$inconsistent, error_table_$invalid_read,
     error_table_$invalid_write, error_table_$invalid_record_length, error_table_$noarg, error_table_$no_operation, error_table_$not_attached,
     error_table_$not_closed, error_table_$not_detached, error_table_$not_open, error_table_$null_info_ptr,
     error_table_$short_record, error_table_$undefined_order_request, error_table_$unimplemented_version)
	fixed binary (35) external;

dcl (imft_et_$cant_get_channel_names, imft_et_$reply_pending, imft_et_$timeout)
	fixed binary (35) external;
/* format: on */

dcl  com_err_ entry () options (variable);
dcl  continue_to_signal_ entry (fixed binary (35));
dcl  create_ips_mask_ entry (ptr, fixed bin, bit (36) aligned);
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  get_wdir_ entry () returns (character (168));
dcl  hcs_$reset_ips_mask entry (bit (36), bit (36));
dcl  hcs_$set_ips_mask entry (bit (36), bit (36));
dcl  ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1));
dcl  ioa_$rsnnl entry options (variable);
dcl  iox_$attach_ioname entry (character (*), pointer, character (*), fixed binary (35));
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  iox_$close entry (pointer, fixed binary (35));
dcl  iox_$destroy_iocb entry (pointer, fixed binary (35));
dcl  iox_$detach_iocb entry (pointer, fixed binary (35));
dcl  iox_$err_no_operation entry () options (variable);
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$propagate entry (pointer);
dcl  iox_$read_record entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35));
dcl  iox_$write_record entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  requote_string_ entry (character (*)) returns (character (*));
dcl  timer_manager_$alarm_call entry (fixed binary (71), bit (2), entry);
dcl  timer_manager_$reset_alarm_call entry (entry);

dcl  (any_other, cleanup, imft_debug_, imft_read_abort_, imft_write_abort_, quit) condition;

dcl  (addr, addcharno, collate, collate9, convert, currentsize, hbound, lbound, length, ltrim, min, null, rtrim, size,
     string, substr, verify) builtin;
%page;
/* Description of a switch attached through this module */

dcl  1 iad aligned based (iad_ptr),
       2 attach_description character (1024) varying,	/* attach description for this I/O switch */
       2 open_description character (24) varying,		/* open description for this I/O switch */
       2 input_switch like switch_info,			/* defines the input terminal switch */
       2 output_switch like switch_info,		/* defines the output terminal switch */
       2 abort_code fixed binary (35),			/* status code of last aborted I/O operation */
       2 flags aligned,
         3 input_direction bit (1) unaligned,		/* ON => receives data from remote system */
         3 abort_in_progress bit (1) unaligned,		/* ON => last I/O operation failed */
         3 debug_mode bit (1) unaligned,		/* ON => trying to debug IMFT: stop on errors */
         3 copy_data bit (1) unaligned,			/* ON => trying to debug connection: copy all data */
         3 pad bit (32) unaligned;

dcl  iad_ptr pointer;


/* Description of a single terminal level I/O switch */

dcl  1 switch_info aligned based,
       2 terminal_iocb_ptr pointer,			/* -> IOCB for terminal level module */
       2 record_buffer_ptr pointer,			/* -> allocated buffer for active records */
       2 flags,
         3 data_present bit (1) unaligned,		/* part of a data record is held here */
         3 control_record_present bit (1) unaligned,	/* a control record is waiting to be read */
         3 first_read bit (1) unaligned,		/* no reads have been done since latest open */
         3 pad_bits bit (33) unaligned,
       2 data_length fixed bin (21),			/* number of characters in held record or part thereof */
       2 rest_of_record_ptr ptr;			/* -> held data, if any */

dcl  rest_of_record char (iad.input_switch.data_length) based (iad.input_switch.rest_of_record_ptr);
%page;
%include iocb;
%page;
%include iox_modes;
%page;
%include tty_read_status_info;

%include tty_get_channel_info;
%page;
%include event_wait_info;
%page;
%include event_wait_channel;
%page;
%include imft_logical_record;
%page;
%include "_imft_cri";

%include "_imft_get_channel_names";
%page;
%include "_imft_std_commands";

     end imft_io_;




		    imft_mail_interface_.pl1        11/21/83  1214.2r w 11/21/83  1211.2       85329



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* Interim mechanism for IMFT to send mail/messages: should be eliminated when mail_system_ allows setting message access
   class and sending interactive messages */

/* Created:  July 1982 by G. Palter as part of proper AIM support */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */


imft_mail_interface_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sender_name character (*) parameter;		/* full name of sender (ie: foreign system) */
dcl  P_destination character (*) parameter;		/* user to receive the message (Person.Project) */
dcl  P_message_type fixed binary parameter;		/* type of message: ordinary or interactive */
dcl  P_subject character (*) parameter;			/* subject of mesage */
dcl  P_text character (*) parameter;			/* text of message */
dcl  P_access_class bit (72) aligned parameter;		/* access class of message */
dcl  P_code fixed binary (35) parameter;


/* Remaining declarations */

dcl  message_text_buffer character (4 * sys_info$max_seg_size) based (message_text_buffer_ptr);
dcl  message_text character (message_text_lth) based (message_text_buffer_ptr);
dcl  message_text_lth fixed binary (21);
dcl  message_text_buffer_ptr pointer;

dcl  (ipc_priv_code, ring1_priv_code) fixed binary (35);

dcl  IMFT_MAIL_INTERFACE_ character (32) static options (constant) initial ("imft_mail_interface_");

dcl  NOTIFY_MSG character (15) static options (constant) initial ("You have mail.
");

dcl  NL character (1) static options (constant) initial ("
");

/* format: off */
dcl  DAY_NAMES (7) character (32) static options (constant) initial (
	"Monday",		"Tuesday",	"Wednesday",	"Thursday",	"Friday",
	"Saturday",	"Sunday");

dcl  MONTH_NAMES (12) character (32) static options (constant) initial (
	"January",	"February",	"March",		"April",		"May",		"June",
	"July",		"August",		"September",	"October",	"November",	"December");

dcl (error_table_$bad_subr_arg, error_table_$bigarg)
	fixed binary (35) external;
/* format: on */

dcl  sys_info$max_seg_size fixed binary (19) external;

dcl  decode_clock_value_$date_time
	entry (fixed binary (71), fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary,
	fixed binary (71), fixed binary, character (3), fixed binary (35));
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  send_mail_$access_class entry (character (*), character (*), pointer, bit (72) aligned, fixed binary (35));
dcl  system_privilege_$ipc_priv_off entry (fixed binary (35));
dcl  system_privilege_$ipc_priv_on entry (fixed binary (35));
dcl  system_privilege_$ring1_priv_off entry (fixed binary (35));
dcl  system_privilege_$ring1_priv_on entry (fixed binary (35));
dcl  user_info_ entry (character (*), character (*));

dcl  (addr, after, before, clock, convert, index, length, ltrim, null, rtrim, substr, unspec) builtin;

dcl  (cleanup, linkage_error) condition;
%page;
/* Deliver a messages to the specified user */

deliver_message:
     entry (P_sender_name, P_destination, P_message_type, P_subject, P_text, P_access_class, P_code);

	if (P_message_type ^= ORDINARY_DELIVERY) & (P_message_type ^= INTERACTIVE_DELIVERY) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	if index (P_destination, ".") = 0 then do;	/* only accepts Person.Project */
INVALID_DESTINATION_SYNTAX:
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;
	if index (after (P_destination, "."), ".") ^= 0 then go to INVALID_DESTINATION_SYNTAX;
	if (before (P_destination, ".") = "") | (after (P_destination, ".") = "") then go to INVALID_DESTINATION_SYNTAX;


/* Try to turn on ring-1 and IPC privileges: we might be sending down... */

	ipc_priv_code, ring1_priv_code = -1;		/* non-zero => we didn't turn privilege on */

	message_text_buffer_ptr = null ();		/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if message_text_buffer_ptr ^= null () then
		     call release_temp_segment_ (IMFT_MAIL_INTERFACE_, message_text_buffer_ptr, (0));
		if ipc_priv_code = 0 then call system_privilege_$ipc_priv_off ((0));
		if ring1_priv_code = 0 then call system_privilege_$ring1_priv_off ((0));
	     end;

	on condition (linkage_error) go to CANT_SET_PRIVILEGE;

	call system_privilege_$ring1_priv_on (ring1_priv_code);
	call system_privilege_$ipc_priv_on (ipc_priv_code);


CANT_SET_PRIVILEGE:
	if P_message_type = ORDINARY_DELIVERY then do;

/* Send a piece of mail: construct the header, send the mail, and send the notification */

	     call get_temp_segment_ (IMFT_MAIL_INTERFACE_, message_text_buffer_ptr, P_code);
	     if P_code ^= 0 then go to RETURN_FROM_DELIVER_MESSAGE;

	     call format_message ();

	     unspec (send_mail_info) = ""b;
	     send_mail_info.version = send_mail_info_version_2;
	     send_mail_info.always_add = "1"b;
	     send_mail_info.sent_from = P_sender_name;

	     call send_mail_$access_class (P_destination, message_text, addr (send_mail_info), P_access_class, P_code);

	     if P_code = 0 then do;			/* got through OK */
		send_mail_info.always_add = "0"b;	/* notification is an express message */
		send_mail_info.wakeup, send_mail_info.notify = "1"b;
		call send_mail_$access_class (P_destination, NOTIFY_MSG, addr (send_mail_info), P_access_class, (0));
	     end;
	end;


	else do;

/* Interactive message: send it without any fancy headers */

	     unspec (send_mail_info) = ""b;
	     send_mail_info.version = send_mail_info_version_2;
	     send_mail_info.wakeup,			/* normal interactive message */
		send_mail_info.always_add = "1"b;
	     send_mail_info.sent_from = P_sender_name;

	     call send_mail_$access_class (P_destination, P_text, addr (send_mail_info), P_access_class, P_code);
	end;


/* All done: cleanup; P_code is already set */

RETURN_FROM_DELIVER_MESSAGE:
	if message_text_buffer_ptr ^= null () then
	     call release_temp_segment_ (IMFT_MAIL_INTERFACE_, message_text_buffer_ptr, (0));

	if ipc_priv_code = 0 then call system_privilege_$ipc_priv_off ((0));
	if ring1_priv_code = 0 then call system_privilege_$ring1_priv_off ((0));

	return;
%page;
/* Formats a message by building the standard header */

format_message:
     procedure ();

	message_text_lth = 0;

	call add ("Date:  ");
	call format_date ();
	call add (NL);

	call add ("From:  ");
	call format_sender ();
	call add (NL);

	if P_subject ^= "" then do;
	     call add ("Subject:  ");
	     call add_trimmed (P_subject);
	     call add (NL);
	end;

	call add ("To:  ");
	call add_trimmed (P_destination);
	call add (NL);

	call add (NL);

	call add_trimmed (P_text);

	return;
%page;
/* Internal to format_message: add text to the message */

add:
	procedure (p_text);

	     text_lth = length (p_text);
	     go to ACTUALLY_ADD_THE_TEXT;


/* Internal to format_message: add text to the message but first remove trailing blanks */

add_trimmed:
	entry (p_text);

	     text_lth = length (rtrim (p_text));


ACTUALLY_ADD_THE_TEXT:
	     if message_text_lth + text_lth > length (message_text_buffer) then do;
		P_code = error_table_$bigarg;
		go to RETURN_FROM_DELIVER_MESSAGE;
	     end;

	     begin;
dcl  new_piece_of_message character (text_lth) unaligned defined (message_text_buffer) position (message_text_lth + 1);
		new_piece_of_message = substr (p_text, 1, text_lth);
	     end;

	     message_text_lth = message_text_lth + text_lth;

	     return;


dcl  p_text character (*) parameter;
dcl  text_lth fixed binary (21);

	end add;
%page;
/* Internal to format_message: formats the current date/time */

format_date:
	procedure ();

dcl  four_digits picture "9999";
dcl  two_digits picture "99";
dcl  time_zone character (3);
dcl  (month, day_of_month, year, hour, minute, day_of_week) fixed binary;
dcl  code fixed binary (35);

	     time_zone = "";			/* use default time zone */

	     call decode_clock_value_$date_time (clock (), month, day_of_month, year, hour, minute, (0), (0),
		day_of_week, time_zone, code);

	     if code ^= 0 then			/* shouldn't happen, but... */
		call add ("unknown");

	     else do;
		call add_trimmed (DAY_NAMES (day_of_week));
		call add (", ");
		call add (ltrim (convert (two_digits, day_of_month), "0"));
		call add (" ");
		call add_trimmed (MONTH_NAMES (month));
		call add (" ");
		call add (convert (four_digits, year));
		call add (" ");
		call add (convert (two_digits, hour));
		call add (":");
		call add (convert (two_digits, minute));
		call add (" ");
		call add (time_zone);
	     end;

	     return;

	end format_date;
%page;
/* Internal to format_message: formats the sender */

format_sender:
	procedure ();

dcl  (my_person_id, my_project_id) character (32);

	     call user_info_ (my_person_id, my_project_id);

	     if P_sender_name ^= "" then do;
		call add_trimmed (P_sender_name);
		call add (" <");
	     end;

	     call add_trimmed (my_person_id);
	     call add (".");
	     call add_trimmed (my_project_id);

	     if P_sender_name ^= "" then call add (">");

	     return;

	end format_sender;

     end format_message;
%page;
%include mlsys_deliver_info;

%include send_mail_info;

     end imft_mail_interface_;




		    imft_pnt_interface_.pl1         12/05/84  1452.6r w 12/05/84  1004.0       24957



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* Interface between IMFT and the system PNT manager */

/* Note:  All errors are translated into some code in imft_et_ to insure that the code can be properly transmitteded
   between the two systems */

/* Created:  April 1982 by G. Palter */
/* Modified 1984-08-15 by E. Swenson for Version 2 PNTs. */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */


imft_pnt_interface_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_system_id character (*) parameter;		/* get_system_password: the system's Person_id */
dcl  P_system_password character (8) aligned parameter;	/* get_system_password: set to the system's password */

dcl  P_user_id character (*) parameter;			/* validate_personid: the user's Person_id */

dcl  P_code fixed binary (35) parameter;


/* Local copies of parameters */

dcl  code fixed binary (35);

/* Remaining declarations */

dcl  system_password char (8);

/* format: off */
dcl (imft_et_$cant_access_pnt, imft_et_$no_card_password, imft_et_$no_person_id)
	fixed binary (35) external;
/* format: on */

dcl  error_table_$id_not_found fixed binary (35) external;
dcl  error_table_$bad_password fixed bin (35) external static;

dcl  pnt_manager_$validate_entry entry (char (*), fixed bin (35));
dcl  pnt_manager_$get_network_password entry (char (*), char (*), bit (1), fixed bin (35));

dcl  addr builtin;

/**/

/* Determines a system's card input password */

get_system_password:
     entry (P_system_id, P_system_password, P_code);

	call pnt_manager_$get_network_password (P_system_id, system_password, ("0"b), code);
	if code ^= 0 then
	     if code = error_table_$bad_password then	/* No network password */
	     code = imft_et_$no_card_password;		/* the ID specified for a system must have one */
	     else if code = error_table_$id_not_found then code = imft_et_$no_person_id;
	     else code = imft_et_$cant_access_pnt;		/* the daemon doesn't have access to the PNT */

	P_system_password = system_password;
	P_code = code;

	return;

/**/

/* Validates that the given Person_id is in the PNT */

validate_personid:
     entry (P_user_id, P_code);

	call pnt_manager_$validate_entry (P_user_id, code);

	if code = 0 then ;				/* found the given ID */

	else if code = error_table_$id_not_found then code = imft_et_$no_person_id;

	else code = imft_et_$cant_access_pnt;		/* the daemon doesn't have access to the PNT */

	P_code = code;

	return;

     end imft_pnt_interface_;




		    imft_receive_object_.pl1        03/15/89  0843.5r w 03/15/89  0800.1      663453



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

/* Receive storage system objects from a remote Multics */

/* Created:  October 1980 by G. Palter */
/* Modified: 28 February 1981 by G. Palter to validate user's access to parent directory and improve messages used to
   report incorrect access on the parent */
/* Modified: April 1982 by G. Palter to finish initial implementation */
/* Modified: July 1982 by G. Palter for true AIM support and to properly process I/O error abort control records */
/* Modified: March 1983 by Robert Coren to recognize local I/O errors and to not hide imft_et_$unknown_status_code */
/* Modified: March 1983 by Robert Coren to process requests for remote transfer */
/* Modified: July 1983 by Robert Coren to fix bug in call to ioa_$rsnnl */
/* Modified: August 1983 by Robert Coren for version 5 backup_control structure */
/* Modified: November 1983 by Robert Coren to turn on ring-1 privilege for pull requests in order to call
   queue_admin_$add_index with impunity */
/* Modified: 1984-10-11 BIM for mseg_message_info */


/****^  HISTORY COMMENTS:
  1) change(88-06-30,Beattie), approve(88-08-01,MCR7948),
     audit(88-10-11,Farley), install(88-10-14,MR12.2-1165):
     a) Add support for extend and update operations.
     b) Add access check to support delete option in remote pulls.
     c) Change all access checks to look for explicit ACLs at all times.
  2) change(88-11-10,Beattie), approve(88-08-01,PBF7948),
     audit(88-11-14,Farley), install(88-11-14,MR12.2-1214):
     Change declaration of local_request_number to match up with what is
     coming from request_descriptor structure to prevent size condtions.
  3) change(88-11-16,Beattie), approve(88-08-01,PBF7948),
     audit(88-11-16,Farley), install(88-11-16,MR12.2-1217):
     Allow driver to access *.imft.acs through links in home directories
     without having status access by first calling hcs_$get_link_target
     to get actual pathname before checking access.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,ifthenstmt,ifthen */

imft_receive_object_:
     procedure (P_imft_driver_info_ptr, P_fis_info_ptr, P_code);

	imft_driver_info_ptr = P_imft_driver_info_ptr;
	fis_info_ptr = P_fis_info_ptr;
	P_code = 0;				/* no errors yet */

	foreign_system_name = rtrim (imft_driver_info.foreign_system.name);

	if fis_info.version ^= FIS_INFO_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if (fis_info.n_iocbs < 2) | (fis_info.n_iocbs > hbound (fis_info.iocbs, 1)) then do;
	     P_code = error_table_$bad_arg;
	     return;
	end;

	master_iocb_ptr = fis_info.iocbs (1);		/* first switch is master terminal ... */
	data_iocb_ptr = fis_info.iocbs (2);		/* ... and second is where objects arrives */

	if (master_iocb_ptr = null ()) | (data_iocb_ptr = null ()) then do;
	     P_code = error_table_$bad_arg;
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

						/** for determining access */
	my_group_id = get_group_id_ ();		/* Person.Project.Tag */
						/* strip tag */
	my_user_id = substr (my_group_id, 1, length (rtrim (my_group_id)) - 2);
	current_ring = get_ring_ ();

/* One time initialization */

	if first_call then do;

	     errfile_dname = get_pdir_ ();		/* place for reload's error files */
	     errfile_ename = "IMFT." || unique_chars_ (""b);
	     errfile_pathname = pathname_ (errfile_dname, errfile_ename);
	     call hcs_$make_seg (errfile_dname, errfile_ename, "", RW_ACCESS_BIN, errfile_ptr, code);
	     if errfile_ptr = null () then do;		/* shouldn't happen, but... */
		call iodd_msg_ (ERROR, MASTER, code, IMFT_RECEIVE_OBJECT_,
		     "Creating ^a as error file for notifications.", errfile_pathname);
		P_code = code;
		return;
	     end;
	     call hcs_$terminate_noname (errfile_ptr, ignore_code);

	     branch_info.version = create_branch_version_2;
						/* initialize branch info structure */
	     branch_info.dir_sw = "1"b;
	     branch_info.copy_sw = "0"b;
	     branch_info.chase_sw = "0"b;
	     branch_info.priv_upgrade_sw = "0"b;
	     branch_info.parent_ac_sw = "1"b;
	     branch_info.mbz1 = ""b;
	     branch_info.mode = SMA_ACCESS;
	     branch_info.mbz2 = ""b;
	     branch_info.rings (1), branch_info.rings (2), branch_info.rings (3) = 7;
	     branch_info.userid = my_group_id;
	     branch_info.bitcnt = 0;
	     branch_info.quota = 0;
	     branch_info.access_class = get_authorization_ ();
	     branch_info.dir_quota = 0;
	     temp_ename = "IMFT_dir." || unique_chars_ (""b);
	     temp_dname = pathname_ (errfile_dname, temp_ename);

	     call hcs_$create_branch_ (errfile_dname, temp_ename, addr (branch_info), code);
	     if code ^= 0 then do;
		call iodd_msg_ (ERROR, MASTER, code, IMFT_RECEIVE_OBJECT_,
		     "Creating holding directory for extend and update file operations.");
		P_code = code;
		return;
	     end;

	     first_call = "0"b;			/* all set */
	end;

/* Setup for operation */

	acl_ptr, errfile_ptr = null ();		/* keep cleanup handler happy */

	errfile_attached, object_in_progress = "0"b;

	on condition (cleanup) call cleanup_handler ();

/*
   Main processing loop: Accept objects from the remote system indefintely or until input is available on the master
   console.  When input is available from the master, control returns to the caller when between objects to permit driver
   command processing
*/

	do while ("1"b);

	     call imft_find_input_switch_ (fis_info_ptr, "1"b, source, code);
	     if code ^= 0 then do;
		call iodd_msg_ (ERROR, MASTER, code, IMFT_RECEIVE_OBJECT_, "Waiting for input from master or remote.")
		     ;
		P_code = code;
		go to RETURN_FROM_RECEIVE_OBJECT;
	     end;

	     if (source = 1) then			/* input from master console */
		go to RETURN_FROM_RECEIVE_OBJECT;

/* Input is available from remote Multics: check for a BOF command */

	     object_in_progress = "0"b;		/* haven't started yet */

	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = 5 * ONE_MINUTE;	/* give it a chance to be read */
	     local_icri.record_ptr = addr (input_buffer);
	     local_icri.record_max_lth = length (input_buffer);

	     call iox_$control (data_iocb_ptr, "read_command_record", addr (local_icri), code);
	     if code ^= 0 then call io_error (code, "Attempting to read from " || foreign_system_name || ".");

	     if (local_icri.record_type = IMFT_SYNC1) | (local_icri.record_type = IMFT_SYNC2) then
		signal condition (imft_resynchronize_driver_);

	     else if local_icri.record_type = IMFT_LOGOUT then signal condition (imft_remote_logout_);

	     else if local_icri.record_type ^= IMFT_BOF & local_icri.record_type ^= IMFT_REMOTE_REQUEST then do;
		call iodd_msg_ (NORMAL, MASTER, NO_ERROR, IMFT_RECEIVE_OBJECT_, "Unexpected command code ^d from ^a.",
		     local_icri.record_type, foreign_system_name);
		P_code = error_table_$fatal_error;	/* make driver reinitialize */
		go to RETURN_FROM_RECEIVE_OBJECT;
	     end;
	     local_bof_reply.abort_request = "0"b;	/* assume everything is OK */
	     local_bof_reply.abort_message = "";

	     acl_count = 2;				/* one entry each for driver and user */
	     allocate general_acl in (system_area) set (acl_ptr);
	     general_acl.version = GENERAL_ACL_VERSION_1;
	     general_acl.count = acl_count;
	     general_acl (DRIVER_ACL_IDX).access_name = rtrim (my_user_id) || ".*";
	     imft_chk_acl.version = IMFT_CHECK_ACL_VERSION_1;
	     imft_chk_acl.foreign_sys_name = foreign_system_name;
	     imft_chk_acl.gen_acl_ptr = acl_ptr;
	     imft_chk_acl.sys_auth_ceiling = imft_driver_info.local_system.access_ceiling;
	     imft_chk_acl.sys_auth_floor = imft_driver_info.local_system.access_floor;

	     object_in_progress = "1"b;		/* in case of QUITs or other failures */
%page;
	     if local_icri.record_type = IMFT_BOF then do;

/**** Object to be sent from other system. */

		local_bof_command = addr (input_buffer) -> bof_command;

		local_request_number, local_bof_reply.request_number = local_bof_command.request_number;

/*
   Determine resting place of the object, the user to notify, log the BOF command, inform the user that something is
   coming, and validate that the driver and user have proper access
*/

		if local_bof_command.foreign_path_given then do;
		     local_dirname = local_bof_command.foreign_dirname;
		     local_entname = local_bof_command.foreign_ename;
		     local_full_pathname = pathname_ (local_dirname, local_entname);
		     foreign_full_pathname =
			pathname_ (local_bof_command.local_dirname, local_bof_command.local_ename);
		end;
		else do;
		     local_dirname = local_bof_command.local_dirname;
		     local_entname = local_bof_command.local_ename;
		     local_full_pathname, foreign_full_pathname = pathname_ (local_dirname, local_entname);
		end;

		if local_bof_command.foreign_user_given then
		     mail_destination = local_bof_command.foreign_user;
		else mail_destination = local_bof_command.local_user;

		foreign_user_id = rtrim (local_bof_command.local_user);
		local_user_id = rtrim (mail_destination);

		imft_chk_acl.user_auth = local_bof_command.local_user_authorization;

		call translate_aim_attributes_ (imft_driver_info.foreign_system.aim_attributes_ptr,
		     local_bof_command.local_user_authorization, imft_driver_info.local_system.aim_attributes_ptr,
		     mail_access_class, code);
		if code ^= 0 then			/* submitter authorization is too high ... */
		     mail_access_class = imft_driver_info.local_system.access_ceiling;

		call iodd_msg_ (LOG, MASTER, NO_ERROR, "",
		     "Request ^d ^a input q^d: receive^[ extension to^]^[ update to^] ^a ^a^/^2xfor ^a^[ from ^a^;^s^]^[^/^2xoriginally ^a^]",
		     local_bof_command.request_number, foreign_system_name, local_bof_command.queue,
		     local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type),
		     local_full_pathname, mail_destination, local_bof_command.foreign_user_given,
		     local_bof_command.local_user, local_bof_command.foreign_path_given, foreign_full_pathname);

		local_personid = before (mail_destination, ".");
		call imft_pnt_interface_$validate_personid (local_personid, code);
		if code ^= 0 then
		     call reject_request (code, "Validating user name """ || rtrim (local_personid) || """.");

		call translate_aim_attributes_ (imft_driver_info.foreign_system.aim_attributes_ptr,
		     local_bof_command.object_access_class, imft_driver_info.local_system.aim_attributes_ptr,
		     local_bof_command.object_access_class, code);
		if code ^= 0 then do;
		     call convert_aim_attributes_ (local_bof_command.object_access_class, octal_string);
		     call reject_request (code,
			"Attempting to translate access class (" || rtrim (octal_string) || ") from "
			|| foreign_system_name || ".");
		end;

		call validate_access ();		/* will abort if not OK */

		if local_bof_command.notify then
		     call notify_user (
			"Beginning reception of^[ extension to^]^[ update to^] ^a ^a from ^a (queue ^d).",
			local_bof_command.extend, local_bof_command.update,
			OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name,
			local_bof_command.queue);

/*
   If control reaches here, as much validation of the request has been performed as possible without actually invoking
   backup_load_:  Inform the other system that it may send the object
*/

		local_icri.version = ICRI_VERSION_1;
		local_icri.timeout = 5 * ONE_MINUTE;	/* give the other system a decent chance */
		local_icri.record_type = IMFT_BOF;	/* this is a reply to their BOF command */
		local_icri.record_ptr = addr (local_bof_reply);
		local_icri.record_lth = 4 * currentsize (local_bof_reply);

		call iox_$control (data_iocb_ptr, "write_reply_record", addr (local_icri), code);
		if code ^= 0 then call io_error (code, "Attempting to reply to " || foreign_system_name || ".");


/*
   Prepare to invoke backup_load_: construct description of reload and terminate the backup system to cleanup from last
   use in this process (if any)
*/

		static_backup_control.version = BACKUP_CONTROL_VERSION_5;
		static_backup_control.tape_entry = nulle;

		string (static_backup_control.options) = ""b;
		static_backup_control.debug_sw = "1"b;
		static_backup_control.error_file = "1"b;
		static_backup_control.first = "1"b;
		static_backup_control.allow_dir_overwrite = "1"b;

		static_backup_control.preattached = "1"b;
						/* we supply the I/O switch */
		static_backup_control.data_iocb = data_iocb_ptr;

		static_backup_control.restore_access_class = "1"b;
						/* restore the AIM access class even though not privileged */

		static_backup_control.enforce_minimum_ring = "1"b;
		static_backup_control.minimum_ring = acs_write_bracket;
						/* don't create anything lower than the ACS segment's write
						   bracket which should reflect local user's normal ring of
						   execution */

		static_backup_control.translate_access_class = "1"b;
		static_backup_control.source_attributes_ptr = imft_driver_info.foreign_system.aim_attributes_ptr;
		static_backup_control.target_attributes_ptr = imft_driver_info.local_system.aim_attributes_ptr;
						/* translate foreign system's AIM attributes to our own */

		static_backup_control.request_count = 1;/* one and only one object to load */

		static_backup_control.object.path = foreign_full_pathname;

		if local_bof_command.extend | local_bof_command.update then
		     static_backup_control.object.new_path = pathname_ (temp_dname, local_entname);

		else if local_bof_command.foreign_path_given then
						/* user requested it be put somewhere else */
		     static_backup_control.object.new_path = local_full_pathname;
		else static_backup_control.object.new_path = "";

		string (static_backup_control.object.switches) = ""b;
		static_backup_control.object.no_primary_sw = "1"b;
		if local_bof_command.object_type = MSF then
						/* always flush old subtree if present */
		     static_backup_control.object.trim_sw = "1"b;
		else static_backup_control.object.trim_sw =
			(local_bof_command.directory_creation_mode = REPLACE_DIRECTORIES);

		call term_$refname ("backup_load_", ignore_code);
		call term_$refname ("backup_map_", ignore_code);
		call term_$refname ("bk_ss_", ignore_code);

		call ios_$attach ("err_file", "file", errfile_pathname, "w", ios_status);
		if ios_status.code ^= 0 then call abort_reception (ios_status.code, "Setting up backup error file.");
		errfile_attached = "1"b;		/* go it */

/* Perform the reload: establish a handler in case anything went wrong during transmission and invoke backup_load_ */

		on condition (imft_read_abort_) call analyze_read_abort;

		call backup_load_ (addr (static_backup_control), code);

RETURN_FROM_BACKUP_LOAD:				/* backup_load_ will read the EOF record */
		call analyze_backup_results (code);

		if ^backup_errors_detected then	/* reload occurred without any troubles ... */
		     if local_bof_command.extend | local_bof_command.update then do;

			string (cpo.copy_items) = ""b;
			cpo.version = COPY_OPTIONS_VERSION_1;
			cpo.caller_name = IMFT_RECEIVE_OBJECT_;
			cpo.copy_items.entry_bound = "1"b;
			string (cpo.flags) = ""b;
			cpo.flags.delete = "1"b;
			cpo.copy_items.extend = local_bof_command.extend;
			cpo.copy_items.update = local_bof_command.update;
			cpo.flags.raw = "1"b;
			cpo.source_dir = temp_dname;
			cpo.source_name = local_entname;
			cpo.target_dir = local_dirname;
			cpo.target_name = local_entname;

			on sub_error_ call copy_sub_err_handler ();

			call copy_ (addr (cpo));
			revert sub_error_;
		     end;

COPY_OPERATION_FINISHED:
		if ^backup_errors_detected then	/* reload occurred without any troubles ... */
		     if local_bof_command.notify then
			call notify_user (
			     "Received^[ extension to^]^[ update to^] ^a ^a without^[ further^] errors from ^a (queue ^d).",
			     local_bof_command.extend, local_bof_command.update,
			     OBJECT_TYPES (local_bof_command.object_type), local_full_pathname,
			     foreign_backup_errors, foreign_system_name, local_bof_command.queue);

		if ^imft_driver_info.old_version then do;
						/* other end is expecting eof_reply to confirm */
						/* successful reception */
		     local_eof_reply.request_number = local_request_number;
		     local_eof_reply.error = backup_errors_detected;

		     local_icri.version = ICRI_VERSION_1;
		     local_icri.timeout = 5 * ONE_MINUTE;
		     local_icri.record_type = IMFT_EOF;
		     local_icri.record_ptr = addr (local_eof_reply);
		     local_icri.record_lth = 4 * currentsize (local_eof_reply);

		     call iox_$control (data_iocb_ptr, "write_reply_record", addr (local_icri), code);
		     if code ^= 0 then call io_error (code, "Attempting to reply to " || foreign_system_name || ".");
		end;

		if backup_errors_detected | foreign_backup_errors then
		     call iodd_msg_ (LOG, MASTER, NO_ERROR, "",
			"^2xNon-fatal errors in transfer detected by ^[^a^;^s^]^[ and ^]^[^a^]",
			foreign_backup_errors, foreign_system_name, foreign_backup_errors & backup_errors_detected,
			backup_errors_detected, imft_driver_info.local_system.name);

		call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2xReceived request ^d.",
		     local_bof_command.request_number);

	     end;					/* if sending to other system */
%page;
/**** Request to queue transfers from here to the other system. */

	     else do;
		local_rr = addr (input_buffer) -> remote_request;
		local_request_number, local_bof_reply.request_number = local_rr.request_number;
		local_dirname = local_rr.dirname;
		local_starname = local_rr.ename;
		local_full_pathname = pathname_ (local_dirname, local_starname);

		if local_rr.foreign_path_given then
		     foreign_equalname = pathname_ (local_rr.foreign_dirname, local_rr.foreign_ename);
		else foreign_equalname = local_full_pathname;

		if local_rr.foreign_user_given then
		     mail_destination = local_rr.foreign_user;
		else mail_destination = local_rr.local_user;

		foreign_user_id = rtrim (local_rr.local_user);
		local_user_id = rtrim (mail_destination);
		general_acl (USER_ACL_IDX).access_name = local_user_id || ".*";

		call translate_aim_attributes_ (imft_driver_info.foreign_system.aim_attributes_ptr,
		     local_rr.local_user_authorization, imft_driver_info.local_system.aim_attributes_ptr,
		     mail_access_class, code);
		if code ^= 0 then			/* submitter authorization is too high ... */
		     mail_access_class = imft_driver_info.local_system.access_ceiling;

		if ^imft_driver_info.remote_request_allowed
						/* this site doesn't permit it */
		     then
		     call reject_request (NO_ERROR,
			foreign_system_name || " does not have permission to request transfers.");

		local_personid = before (mail_destination, ".");
		call imft_pnt_interface_$validate_personid (local_personid, code);
		if code ^= 0 then
		     call reject_request (code, "Validating user name """ || rtrim (local_personid) || """.");

		call iodd_msg_ (LOG, MASTER, NO_ERROR, "",
		     "Request ^d ^a input q^d: transmit^[ extension^]^[ update^] ^a^/^2xfrom ^a^[ for ^a^;^s^]^[^/^2xas ^a^]",
		     local_request_number, foreign_system_name, local_rr.queue, local_rr.extend, local_rr.update,
		     local_full_pathname, mail_destination, local_rr.foreign_user_given, local_rr.local_user,
		     local_rr.foreign_path_given, foreign_equalname);

		call validate_acs (R_ACCESS);
		user_ring = max (local_rr.local_user_ring, acs_write_bracket);

		call submit_request;

/*
   if we return to here, we submitted the request, or part of it, anyway, so tell
   the other system
*/

		local_icri.version = ICRI_VERSION_1;
		local_icri.timeout = 5 * ONE_MINUTE;	/* give the other system a decent chance */
		local_icri.record_type = IMFT_BOF;	/* this is a reply to their BOF command */
		local_icri.record_ptr = addr (local_bof_reply);
		local_icri.record_lth = 4 * currentsize (local_bof_reply);

		call ioa_$rsnnl ("Queued ^d request^[^;s^] on ^a for request ^d^[ with ^d error^[^;s^]^].",
		     local_bof_reply.abort_message, ignore_fb21, n_submitted, (n_submitted = 1),
		     imft_driver_info.local_system.name, local_request_number, (n_not_submitted > 0), n_not_submitted,
		     (n_not_submitted = 1));

		call iox_$control (data_iocb_ptr, "write_reply_record", addr (local_icri), code);
		if code ^= 0 then call io_error (code, "Attempting to reply to " || foreign_system_name || ".");

		call iodd_msg_ (LOG, MASTER, NO_ERROR, "",
		     "^2xQueued ^d request^[^;s^] for request ^d^[ with ^d error^[^;s^]^].", n_submitted,
		     (n_submitted = 1), local_request_number, (n_not_submitted > 0), n_not_submitted,
		     (n_not_submitted = 1));

	     end;					/* if queueing transfers from here to other system */

	     object_in_progress = "0"b;		/* all done with this one */

WAIT_FOR_NEXT_OBJECT:
	end;					/* do while ("1"b) */

RETURN_FROM_RECEIVE_OBJECT:
	call cleanup_handler ();

	return;
%page;
/*
   Handler for imft_read_abort_:  This condition is raised during reading of backup records if transmission was
   prematurely terminated at the remote system
*/

analyze_read_abort:
     procedure ();

	local_icri.version = ICRI_VERSION_1;
	local_icri.timeout = 5 * ONE_MINUTE;		/* give the remote system sometime */
	local_icri.record_ptr = addr (input_buffer);
	local_icri.record_max_lth = length (input_buffer);

	call iox_$control (data_iocb_ptr, "get_abort_info", addr (local_icri), code);
	if code ^= 0 then call io_error (code, "Attempting to read from " || foreign_system_name || ".");

	if (local_icri.record_type = IMFT_SYNC1) | (local_icri.record_type = IMFT_SYNC2) then do;
	     call notify_user ("Request for ^a deferred: ^a requested driver to reinitialize.", local_full_pathname,
		foreign_system_name);
	     signal condition (imft_resynchronize_driver_);
	end;

	else if local_icri.record_type = IMFT_LOGOUT then do;
	     call notify_user ("Request for ^a deferred: ^a's output driver disconnected.", local_full_pathname,
		foreign_system_name);
	     signal condition (imft_remote_logout_);
	end;

	else if local_icri.record_type = IMFT_EOF then do;/* backup_load_ will keep reading after object is loaded: */
						/* the EOF record after the object is trapped here */
	     eof_command_ptr = local_icri.record_ptr;
	     go to RETURN_FROM_BACKUP_LOAD;
	end;


	else if local_icri.record_type = IMFT_ABORT then do;
	     abort_command_ptr = local_icri.record_ptr;
	     if abort_command.reason = IMFT_ABORT_IO_ERROR | abort_command.reason = IMFT_ABORT_LOCAL_IO_ERROR then do;
		if abort_command.reason = IMFT_ABORT_IO_ERROR
						/* came from foreign system */
		     then
		     abort_command.code = imft_convert_status_code_$decode (abort_command.code);
		call io_error (abort_command.code, "Attempting to read from " || foreign_system_name || ".");
	     end;
	     else if abort_command.reason = IMFT_ABORT_ABORTED then
		call abort_reception (NO_ERROR, foreign_system_name || " terminated transmission prematurely.");
	     else if abort_command.reason = IMFT_ABORT_RESTARTED then
		call abort_reception (NO_ERROR, "Operator at " || foreign_system_name || " restarted the request.");
	     else if (abort_command.reason = IMFT_ABORT_DEFERRED) | (abort_command.reason = IMFT_ABORT_SAVED) then
		call abort_reception (NO_ERROR,
		     "Operator at " || foreign_system_name || " deferred transmission until a later time.");
	     else if abort_command.reason = IMFT_ABORT_CANCELLED then
		call abort_reception (NO_ERROR, "Operator at " || foreign_system_name || " cancelled transmission.");
	     else call abort_reception (NO_ERROR,
		     foreign_system_name || " terminated transmission for an unknown reason.");
	end;

	else do;
	     call iodd_msg_ (NORMAL, MASTER, NO_ERROR, IMFT_RECEIVE_OBJECT_, "Unexpected command code ^d from ^a.",
		local_icri.record_type, foreign_system_name);
	     P_code = error_table_$fatal_error;		/* make driver reinitialize */
	     go to RETURN_FROM_RECEIVE_OBJECT;
	end;
     end analyze_read_abort;
%page;
/* Cleanup before returning to caller */

cleanup_handler:
     procedure ();

	if acl_ptr ^= null () then do;
	     free general_acl in (system_area);
	     acl_ptr = null ();
	end;

	if errfile_ptr ^= null () then do;
	     call hcs_$terminate_noname (errfile_ptr, ignore_code);
	     errfile_ptr = null ();
	end;

	if errfile_attached then do;
	     call ios_$detach ("err_file", "", "", ios_status);
	     call hcs_$truncate_file (errfile_dname, errfile_ename, 0, ignore_code);
	     call hcs_$set_bc (errfile_dname, errfile_ename, 0, ignore_code);
	     errfile_attached = "0"b;
	end;

	if object_in_progress then do;
	     call iodd_msg_ (NORMAL, MASTER, NO_ERROR, IMFT_RECEIVE_OBJECT_, "Processing of request ^d terminated.",
		local_request_number);
	     object_in_progress = "0"b;
	end;

	return;

     end cleanup_handler;
%page;
copy_sub_err_handler:
     procedure;

dcl  1 ci aligned like condition_info;
dcl  local_error_message character (1024);

	call find_condition_info_ (null (), addr (ci), ignore_code);
	sub_error_info_ptr = ci.info_ptr;

	if sub_error_info.name ^= "copy_" then do;
CONTINUE_TO_SIGNAL:
	     call continue_to_signal_ (ignore_code);
	     goto END_COPY_HANDLER;
	end;
	else if sub_error_info.info_ptr = null then goto CONTINUE_TO_SIGNAL;
	else if copy_error_info.copy_options_ptr ^= addr (cpo) then goto CONTINUE_TO_SIGNAL;

	code = sub_error_info.status_code;
	if code ^= 0 then do;
	     if code = error_table_$unsupported_operation & copy_error_info.operation = "entry bound" then
		go to COPY_OPERATION_FINISHED;

	     backup_errors_detected = "1"b;
	     call convert_status_code_ (code, shortinfo, code_message);
	     call ioa_$rsnnl ("Error occured in extend/update operation:^[^s^; ^a^]^/(^a)", local_error_message,
		ignore_fb21, (sub_error_info.info_string = ""), sub_error_info.info_string, code_message);
	     call notify_user (local_error_message);
	end;
	go to COPY_OPERATION_FINISHED;

END_COPY_HANDLER:
     end copy_sub_err_handler;
%page;
/****^
   Validates access to receive a transfer request:  Let TPerson.TProj be the user who is to receive the file/subtree,
   SPerson.SProj be the user (on the other system) who is sending the file/subtree, MPerson.MProj be the user who is
   running the daemon, and let TDir be the directory into which the file/subtree will be placed.  Then:

      (1) SPerson.SProj must have explicit write access to the segment:
	   >udd>TProj>TPerson>SSite.imft.acs
	where SSite is the name of the foreign system (the foreign_system keyword in the I/O daemon tables),

      (2) TPerson.TProj and MPerson.MProj must have explicit "sma" access to TDir, and

      (3) the access class of DIR must be equal to the access class of the file/subtree from the other system.

   To perform these checks, MPerson.MProj requires "s" access to the parent of TDir and to >udd>TProj>TPerson.

   The user's access to the directory is checked using the highest value of the following 3 items;
      (1) write bracket of the user's ACS segment on local system as the user's ring of execution.
      (2) the foreign user ring of execution.
      (3) driver ring of execution.
*/

validate_access:
     procedure () options (non_quick);			/* because it has lots of automatic storage */

dcl  dir_access_class bit (72) aligned;
dcl  dir_access_class_text character (256);
dcl  local_error_message character (1024);
dcl  local_pathname character (168);
dcl  object_access_class_text character (256);
dcl  parent_dirname character (168);
dcl  parent_ename character (32);
dcl  transfer_ring fixed binary (3);

	call validate_acs (W_ACCESS);			/* check access on ACS */
	transfer_ring = max (local_bof_command.local_user_ring, acs_write_bracket);

	if local_dirname = ">" then			/* can't transfer to the root */
	     call reject_request (NO_ERROR, "IMFT can not create branches under the root.");
%page;
/**** Both driver and user must have explicit SMA access to parent directory */

	call expand_pathname_ (local_dirname, parent_dirname, parent_ename, ignore_code);
	imft_chk_acl.dirname = parent_dirname;
	imft_chk_acl.ename = parent_ename;
	imft_chk_acl.dir_access = SMA_ACCESS;
	imft_chk_acl.seg_access = RW_ACCESS;
	imft_chk_acl.check_aim = "0"b;		/* check_object_acl AIM check is not right for parent dir */
	imft_chk_acl.effective_ring = transfer_ring;
	imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX;	/* by default, error is driver's */
	general_acl (USER_ACL_IDX).access_name = local_user_id || ".*";

	call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	if code = 0 then code = imft_chk_acl.error_code;
	if code ^= 0 then do;
	     if code = error_table_$unimplemented_version then call fatal_ica_error ();
	     call set_va_dir_sma_error_message (imft_chk_acl.bad_acl_idx);
	     call reject_request (code, local_error_message);
	end;					/* if code ^= 0 */

	code = 0;
	do idx = 1 to hbound (general_acl.entries, 1);
	     if general_acl (idx).status_code ^= 0 then do;
		code = general_acl (idx).status_code;
		call convert_status_code_ (code, shortinfo, code_message);
		call set_va_dir_sma_error_message (idx);
		call notify_user (REQ_TERMED_STR, code ^= 0, code_message, local_error_message, local_dirname);
	     end;
	end;

	if code ^= 0 then
	     call reject_request_no_notify (NO_ERROR,
		"Insufficient driver/user access to parent directory to receive object.");

/**** Check AIM of parent directory. */

	call hcs_$get_access_class ((parent_dirname), (parent_ename), dir_access_class, code);
	if code ^= 0 then
	     call reject_request (code, "Attempting to determine access class of parent directory to object.");

	if ^aim_check_$equal (dir_access_class, local_bof_command.object_access_class) then do;
	     dir_access_class_text, object_access_class_text = "";
	     call convert_authorization_$to_string_short (dir_access_class, dir_access_class_text, ignore_code);
	     call convert_authorization_$to_string_short (local_bof_command.object_access_class,
		object_access_class_text, ignore_code);
	     call ioa_$rsnnl (
		"Access class of ^a (^[^a^;^ssystem_low^]) must be equal to access class of object on ^a (^[^a^;^ssystem_low^]).",
		local_error_message, ignore_fb21, local_dirname, (dir_access_class_text ^= ""), dir_access_class_text,
		foreign_system_name, (object_access_class_text ^= ""), object_access_class_text);
	     call reject_request (error_table_$ai_restricted, local_error_message);
	end;
%page;
	if local_bof_command.extend | local_bof_command.update then do;

/**** Object must already exist and have explicit ACL entries of RW for both driver and user. */

	     local_pathname = pathname_ (local_dirname, local_entname);
	     imft_chk_acl.dirname = local_dirname;
	     imft_chk_acl.ename = local_entname;
	     imft_chk_acl.dir_access = SMA_ACCESS;
	     imft_chk_acl.seg_access = RW_ACCESS;
	     imft_chk_acl.check_aim = "1"b;
	     imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX;	/* by default, error is driver's */
	     general_acl (USER_ACL_IDX).access_name = local_user_id || ".*";

	     call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	     if code = 0 then code = imft_chk_acl.error_code;
	     if code ^= 0 then do;
		if code = error_table_$unimplemented_version then call fatal_ica_error ();
		call reject_request (NO_ERROR, (imft_chk_acl (imft_chk_acl.bad_acl_idx).error_message));
	     end;

	     code = 0;
	     do idx = 1 to hbound (general_acl.entries, 1);
		if general_acl (idx).status_code ^= 0 then do;
		     code = general_acl (idx).status_code;
		     call notify_user (REQ_TERMED_STR, "0"b, code_message, imft_chk_acl (idx).error_message,
			local_pathname);		/* code_message is already in .error_message */
		end;
	     end;

	     if code ^= 0 then
		call reject_request_no_notify (NO_ERROR,
		     "Insufficient driver/user access to extend or update object.");

	     if ^(imft_chk_acl.type = ENTRY_TYPE_SEGMENT | imft_chk_acl.type = ENTRY_TYPE_MSF) then do;

		if index (imft_chk_acl.type, "-") = 1 then
		     local_type = substr (imft_chk_acl.type, 2);
		else local_type = imft_chk_acl.type;

		call ioa_$rsnnl ("Can only ^[extend^]^[update^] with segments or MSFs, not with ^a type object.",
		     local_error_message, ignore_fb21, local_bof_command.extend, local_bof_command.update, local_type)
		     ;
		call reject_request (NO_ERROR, local_error_message);
	     end;

	end;					/* if extend or update */

	return;					/* passes */
%page;
set_va_dir_sma_error_message:
	proc (p_idx);

dcl  p_idx fixed binary parameter;

	     if code = error_table_$moderr | code = error_table_$user_not_found then
		call ioa_$rsnnl (
		     "^[Driver^;User^] (^a) must have an explicit ACL entry of SMA to parent directory of object to be received.",
		     local_error_message, ignore_fb21, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name,
		     local_pathname);
	     else call ioa_$rsnnl (
		     "Unable to determine ^a's and ^a's access to parent directory of object to be received.",
		     local_error_message, ignore_fb21, local_user_id, my_user_id);

	end set_va_dir_sma_error_message;

     end validate_access;
%page;
/*
   Check for the existence of the ACS described in introductory comment to validate_access,
   and ensure that the foreign user has the appropriate access (W for transferring
   objects to this system, or R for requesting that they be transferred to SSite).
*/

validate_acs:
     procedure (access_required);

dcl  access_required bit (3) parameter;

dcl  link_dirname character (168);
dcl  link_ename character (32);
dcl  local_dirname character (168);
dcl  local_ename character (32);
dcl  local_error_message character (1024);
dcl  local_pathname character (168);

	local_dirname, imft_chk_acl.dirname =
	     ">udd>" || after (local_user_id, ".") || ">" || before (local_user_id, ".");
	local_ename, imft_chk_acl.ename = foreign_system_name || ".imft.acs";
	local_pathname = pathname_ (local_dirname, local_ename);
						/* ACS path could be a link in "home" directory to which */
						/* daemon doesn't even have status access, */
						/* find actual path */
	call hcs_$get_link_target (local_dirname, local_ename, link_dirname, link_ename, code);

	if code = 0 | code = error_table_$noentry then do;

						/** previous call could have changed pathname */
	     imft_chk_acl.dirname = link_dirname;
	     imft_chk_acl.ename = link_ename;
	     local_pathname = pathname_ (link_dirname, link_ename);
	end;

	if code ^= 0 then go to VALIDATE_ACS_ERROR;

	imft_chk_acl.dir_access = S_ACCESS;
	imft_chk_acl.seg_access = access_required;
	imft_chk_acl.check_aim = "0"b;
	imft_chk_acl.effective_ring = 0;		/* we want to know what it is without getting an error */
	imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX;	/* by default, error is driver's */
	general_acl (USER_ACL_IDX).access_name = foreign_user_id || ".*";

	call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	if code = 0 then code = imft_chk_acl.error_code;
	if code ^= 0 then do;

	     if code = error_table_$unimplemented_version then call fatal_ica_error ();

VALIDATE_ACS_ERROR:
	     call set_acs_error_message ();
	     call reject_request (code, local_error_message);
	end;

	if general_acl (USER_ACL_IDX).status_code ^= 0 then do;
	     code = general_acl (USER_ACL_IDX).status_code;
	     call set_acs_error_message ();		/* code can be set to 0 in this call */
	     call reject_request (code, local_error_message);
	end;

	acs_write_bracket = max (imft_chk_acl.object_ring, current_ring);
						/* restrict transfers to user's probable ring of */
						/* execution unless we operate in a higher ring */

	return;
%page;
/**** Support routine for validate_acs to generate an applicable error message. */

set_acs_error_message:
	proc;

	     if code = error_table_$noentry then do;
		call ioa_$rsnnl ("^a has not established an ACS segment in ^a to control transfers ^[from^;to^] ^a.",
		     local_error_message, ignore_fb21, local_user_id, imft_chk_acl.dirname,
		     (access_required = W_ACCESS), foreign_system_name);
		code = 0;				/* no need to include the error_table_ message */
	     end;
	     else if code = error_table_$moderr | code = error_table_$user_not_found then
		call ioa_$rsnnl ("^a has not given ^a permission to transfer files ^[from^;to^] ^a ^[to^;from^] ^a.",
		     local_error_message, ignore_fb21, local_user_id, foreign_user_id, (access_required = W_ACCESS),
		     foreign_system_name, (access_required = W_ACCESS), imft_driver_info.local_system.name);
	     else call ioa_$rsnnl ("Attempting to determine ^a's access to ^a.", local_error_message, ignore_fb21,
		     foreign_user_id, local_pathname);

	end set_acs_error_message;

     end validate_acs;
%page;
/*
   Submit one or more requests for transfer to the foreign system as specified by
   the starname given in a request for remote transfer. This code is essentially lifted
   from enter_imft_request
*/

submit_request:
     procedure;

dcl  queue_index fixed bin;
dcl  request_type character (24);
dcl  transmit_driver_id character (32);
dcl  queue_ename character (32);
dcl  local_error_message character (1024);
dcl  queue_picture picture "9";
dcl  access_mode bit (36) aligned;
dcl  queue_mode bit (36) aligned;
dcl  chase_control bit (2);
dcl  have_starname bit (1);
dcl  submitted_a_request bit (1);
dcl  reported_error bit (1);
dcl  reported_dir_sma_warning bit (1);
dcl  entry_idx fixed bin;
dcl  priv_code fixed bin (35);

dcl  1 local_ft_request aligned like ft_request;

	queue_index = 0;				/* for cleanup handler */
	priv_code = -1;				/* so it won't look like we turned it on */
	star_entry_ptr, star_names_ptr = null ();

	on cleanup
	     begin;
	     if star_names_ptr ^= null () then do;
		free star_names in (system_area);
		star_names_ptr = null ();
	     end;

	     if star_entry_ptr ^= null () then do;
		free star_entries in (system_area);
		star_entry_ptr = null ();
	     end;

	     if queue_index ^= 0 then do;
		call message_segment_$close (queue_index, ignore_code);
		queue_index = 0;
	     end;

	     if priv_code = 0			/* we turned ring 1 privilege on */
		then
		call system_privilege_$ring1_priv_off (ignore_code);

	end;

	local_user_access_id = local_user_id || ".*";
	request_type = "To_" || foreign_system_name;
	queue_ename = rtrim (request_type) || "_" || convert (queue_picture, local_rr.queue) || ".ms";

/* turn on ring 1 privilege in preparation for call to queue_admin_$add_index */

	on linkage_error ;				/* if we don't have access to the gate, we'll risk it */
	call system_privilege_$ring1_priv_on (priv_code); /* sets code to 0 iff privilege was off before and */
	revert linkage_error;			/* we turned it on */

	call message_segment_$open (imft_data_$queue_dirname, queue_ename, queue_index, code);
	if code ^= 0 then call reject_request (code, "Opening " || pathname_ (imft_data_$queue_dirname, queue_ename));

	call hcs_$get_user_access_modes (imft_data_$queue_dirname, queue_ename, local_user_access_id, (user_ring),
	     access_mode, queue_mode, code);
	if code ^= 0 then
	     call reject_request (code,
		"Could not determine access to " || pathname_ (imft_data_$queue_dirname, queue_ename));

	if (queue_mode & A_EXTENDED_ACCESS) ^= A_EXTENDED_ACCESS
						/* not enough access at all */
	     then
	     call reject_request (NO_ERROR,
		"User has insufficient access to " || rtrim (request_type) || " queue "
		|| convert (queue_picture, local_rr.queue));

	call iod_info_$driver_access_name (request_type, transmit_driver_id, code);
	if code ^= 0 then do;
	     call ioa_$rsnnl ("Receiving driver attempting to determine transmiting driver ident on ^a system.",
		local_error_message, ignore_fb21, imft_driver_info.local_system.name);
	     call reject_request (code, local_error_message);
	end;
	general_acl (DRIVER_ACL_IDX).access_name = transmit_driver_id;

/* Fill in constant portion of the ft_request */

	unspec (local_ft_request) = ""b;

	local_ft_request.header.hdr_version = queue_msg_hdr_version_1;
	local_ft_request.header.message_type = FT_MESSAGE_TYPE;
	local_ft_request.header.notify = local_rr.notify;
	local_ft_request.header.orig_queue = local_rr.queue;
	local_ft_request.header.std_length = currentsize (local_ft_request);
	local_ft_request.delete = local_rr.delete;
	local_ft_request.extend = local_rr.extend;
	local_ft_request.update = local_rr.update;

	local_ft_request.version = FT_REQUEST_VERSION_1;
	if foreign_user_id ^= local_user_id then do;	/* foreign user is different from local user */
	     local_ft_request.foreign_user = foreign_user_id;
	     local_ft_request.foreign_user_given = "1"b;
	end;

	local_ft_request.foreign_path_given = local_rr.foreign_path_given;
	chase_control = local_rr.chase_control;

	n_submitted = 0;
	n_not_submitted = 0;

	call check_star_name_$entry (local_starname, code);
	have_starname = (code ^= 0);
	reported_dir_sma_warning = "0"b;		/* SMA access warning is to be reported once per request */

	if have_starname then do;			/* more than one object */
	     star_entry_ptr, star_names_ptr = null ();
	     submitted_a_request, reported_error = "0"b;
	     if chase_control = ALWAYS_CHASE then
		call hcs_$star_ (local_dirname, local_starname, star_ALL_ENTRIES, system_area_ptr, star_entry_count,
		     star_entry_ptr, star_names_ptr, code);
	     else call hcs_$star_ (local_dirname, local_starname, star_BRANCHES_ONLY, system_area_ptr, star_entry_count,
		     star_entry_ptr, star_names_ptr, code);
	     if code ^= 0 then call reject_request (code, "Attempting to process star names.");

	     do entry_idx = 1 to star_entry_count;
		call process_single_request (local_dirname, star_names (star_entries (entry_idx).nindex));

PROCESS_NEXT_STAR_ENTRY:
	     end;
	     free star_names in (system_area);
	     free star_entries in (system_area);
	     star_entry_ptr, star_names_ptr = null ();
	     if ^submitted_a_request then
		if reported_error then
		     call reject_request_no_notify (NO_ERROR, NO_OBJ_FND_SATISFY_REQ_STR);
		else call reject_request (NO_ERROR, NO_OBJ_FND_SATISFY_REQ_STR);
	end;

	else call process_single_request (local_dirname, local_starname);

	call message_segment_$close (queue_index, ignore_code);

	if priv_code = 0				/* if we turned ring-1 privilege on */
	     then
	     call system_privilege_$ring1_priv_off (ignore_code);

	return;
%page;
/* Internal to submit_request: Performs all necessary processing to submit a single request */

process_single_request:
	procedure (p_dirname, p_ename);

dcl  (p_dirname, p_ename) character (*) parameter;

dcl  (local_dirname, local_pathname, parent_dirname, real_dirname) character (168);
dcl  (local_ename, parent_ename, real_ename, foreign_ename) character (32);

dcl  entry_bit_count fixed binary (24);
dcl  entry_type fixed binary (2);

dcl  local_error_message character (1024);
dcl  request_id character (19);
dcl  the_message_id bit (72) aligned;

dcl  1 auto_mseg_message_info aligned like mseg_message_info;

	     local_dirname = p_dirname;
	     local_ename = p_ename;
	     local_pathname = pathname_ (local_dirname, local_ename);

/* Determine the type of entry and, if requested and the entry is a link, determine its actual target */

	     call hcs_$status_minf (local_dirname, local_ename, HCS_DONT_CHASE, entry_type, entry_bit_count, code);
	     if code ^= 0 then
COULD_NOT_STATUS_BRANCH:
		call abort_single_request (code, local_pathname, "Determining type of object.");

	     if (entry_type = star_LINK) then
		if (^have_starname & (chase_control = DEFAULT_CHASE)) | (chase_control = ALWAYS_CHASE) then do;
		     call hcs_$get_link_target (local_dirname, local_ename, real_dirname, real_ename, code);
		     if code ^= 0 then
			call abort_single_request (code, local_pathname, "Determining link target of object.");

		     local_dirname = real_dirname;
		     local_ename = real_ename;
		     call hcs_$status_minf (local_dirname, local_ename, HCS_DONT_CHASE, entry_type, entry_bit_count,
			code);
		     if code ^= 0 then go to COULD_NOT_STATUS_BRANCH;
		end;
		else call abort_single_request (error_table_$link, local_pathname,
			"Object to be transmitted can not be a link.");
%page;
/****
      Check the user's and the daemon's access to object.  Both must have
      explicit non-null access to the branch.
*/

	     imft_chk_acl.dirname = local_dirname;
	     imft_chk_acl.ename = local_ename;
	     imft_chk_acl.dir_access = S_ACCESS;
	     imft_chk_acl.seg_access = R_ACCESS;
	     imft_chk_acl.check_aim = "0"b;		/* output daemon will check AIM */
	     imft_chk_acl.effective_ring = user_ring;
	     imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX;	/* by default, error is driver's */
	     general_acl (USER_ACL_IDX).access_name = local_user_id || ".*";

	     call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	     if code = 0 then code = imft_chk_acl.error_code;
	     if code ^= 0 then
		if code = error_table_$unimplemented_version then
		     call fatal_ica_error ();
		else call abort_single_request (NO_ERROR, local_pathname,
			(imft_chk_acl (imft_chk_acl.bad_acl_idx).error_message));

	     code = 0;
	     do idx = 1 to hbound (general_acl.entries, 1);
		if general_acl (idx).status_code ^= 0 then do;
		     code = general_acl (idx).status_code;
		     call notify_user (REQ_TERMED_STR, "0"b, code_message, imft_chk_acl (idx).error_message,
			local_pathname);		/* code_message is already in .error_message */
		end;
	     end;

	     if code ^= 0 then
		call abort_single_request_no_notify (NO_ERROR, local_pathname,
		     "Insufficient driver/user access to object.");

/* If -file or -subtree was specified, verify that the branch is of the appropriate type */

	     if ^(imft_chk_acl.type = ENTRY_TYPE_DIRECTORY) & ^local_rr.include_files then
		if ^have_starname then
		     call reject_request (NO_ERROR, "Files may not be specified when ""-subtree"" is used.");

	     if (imft_chk_acl.type = ENTRY_TYPE_DIRECTORY) & ^local_rr.include_subtrees then
		if ^have_starname then do;
		     call ioa_$rsnnl ("Subtrees may not be specified when ""-^[file^]^[extend^]^[update^]"" is used.",
			local_error_message, ignore_fb21, ^(local_rr.extend | local_rr.update), local_rr.extend,
			local_rr.update);
		     call reject_request (NO_ERROR, local_error_message);
		end;

	     if (local_rr.extend | local_rr.update)
		& ^((imft_chk_acl.type = ENTRY_TYPE_SEGMENT) | (imft_chk_acl.type = ENTRY_TYPE_MSF)) then do;

		if index (imft_chk_acl.type, "-") = 1 then
		     local_type = substr (imft_chk_acl.type, 2);
		else local_type = imft_chk_acl.type;

		call ioa_$rsnnl ("Can only ^[extend^]^[update^] with segments or MSFs, not with ^a type objects.",
		     local_error_message, ignore_fb21, local_rr.extend, local_rr.update, local_type);
		call abort_single_request (NO_ERROR, local_pathname, local_error_message);
	     end;

/* Construct the foreign pathname if -target_pathname was specified */

	     if local_ft_request.foreign_path_given then do;
		call get_equal_name_ (local_ename, local_rr.foreign_ename, foreign_ename, code);
		if code ^= 0 then
		     call abort_single_request (code, local_pathname,
			"Applying " || rtrim (local_rr.foreign_ename) || " to " || rtrim (local_ename));
	     end;
%page;
/****
      Must always have S access to containing or parent directory for both
      driver and user.

      If the -delete option was used or local object is being extended or
      updated, both driver and user must have explicit SMA.
*/

	     call expand_pathname_ (local_dirname, parent_dirname, parent_ename, ignore_code);
	     imft_chk_acl.dirname = parent_dirname;
	     imft_chk_acl.ename = parent_ename;
	     imft_chk_acl.dir_access = S_ACCESS;
	     imft_chk_acl.seg_access = R_ACCESS;
	     imft_chk_acl.check_aim = "0"b;		/* AIM checking done by output daemon */
	     imft_chk_acl.effective_ring = user_ring;
	     imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX;	/* by default, error is driver's */
	     general_acl (USER_ACL_IDX).access_name = local_user_id || ".*";

	     call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	     if code = 0 then code = imft_chk_acl.error_code;
	     if code ^= 0 then do;
		if code = error_table_$unimplemented_version then call fatal_ica_error ();
		call set_dir_s_error_message (imft_chk_acl.bad_acl_idx);
		call reject_request (code, local_error_message);
	     end;					/* if code ^= 0 */

	     code = 0;
	     do idx = 1 to hbound (general_acl.entries, 1);
		if general_acl (idx).status_code ^= 0 then do;
		     code = general_acl (idx).status_code;
		     call set_dir_s_error_message (idx);
		     call convert_status_code_ (code, shortinfo, code_message);
		     call notify_user (REQ_TERMED_STR, code ^= 0, code_message, local_error_message, local_pathname);
		end;
	     end;

	     if code ^= 0 then
		call reject_request_no_notify (NO_ERROR, "Insufficient driver/user access to parent directory.");
%page;
/****
      SMA access is not critical here.  S access for both driver and user has
      already been checked above and was all right.  The transmitting daemon may
      be able to do the proper checking.  In case it does fail, the transfer
      will still occur; only the delete operation will not be done.  Since this
      access check is done on the parent directory, there is no need to go
      through this check for each match on a star name once it has been
      reported.
*/

	     if local_rr.delete & ^reported_dir_sma_warning then do;
						/* need SMA to parent directory for this case */

		imft_chk_acl.dir_access = SMA_ACCESS;
		imft_chk_acl.seg_access = RW_ACCESS;
		imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX;
						/* by default, error is driver's */
		general_acl (USER_ACL_IDX).access_name = local_user_id || ".*";

		call imft_util_$check_object_acl (addr (imft_chk_acl), code);
		if code = 0 then code = imft_chk_acl.error_code;
		if code ^= 0 then do;
		     if code = error_table_$unimplemented_version then call fatal_ica_error ();
		     call set_dir_sma_error_message (imft_chk_acl.bad_acl_idx);
		     call notify_user (local_error_message);
		end;				/* if code ^= 0 */

		do idx = 1 to hbound (general_acl.entries, 1);
		     if general_acl (idx).status_code ^= 0 then do;
			code = general_acl (idx).status_code;
			call set_dir_sma_error_message (idx);
			call notify_user (local_error_message);
		     end;
		end;

	     end;					/* if local_rr.delete */
%page;
/* Submit the request */

	     local_ft_request.header.msg_time = clock ();

	     local_ft_request.header.dirname = local_dirname;
	     local_ft_request.header.ename = local_ename;

	     if local_ft_request.foreign_path_given then do;
		local_ft_request.foreign_dirname = local_rr.foreign_dirname;
		local_ft_request.foreign_ename = foreign_ename;
	     end;

	     if entry_type = star_DIRECTORY then
		local_ft_request.directory_creation_mode = local_rr.directory_creation_mode;
	     else local_ft_request.directory_creation_mode = "00"b;

	     mseg_message_info_ptr = addr (auto_mseg_message_info);
	     unspec (mseg_message_info) = ""b;
	     mseg_message_info.version = MSEG_MESSAGE_INFO_V1;
	     mseg_message_info.ms_ptr = addr (local_ft_request);
	     mseg_message_info.ms_len = 36 * currentsize (local_ft_request);
	     mseg_message_info.sender_id = rtrim (mail_destination) || ".*";
	     mseg_message_info.sender_level = current_ring;
	     mseg_message_info.sender_authorization, mseg_message_info.ms_access_class = mail_access_class;
	     mseg_message_info.sender_max_authorization = mail_access_class;
	     mseg_message_info.sender_process_id = ""b;
	     mseg_message_info.ms_id = ""b;

	     call queue_admin_$add_index (queue_index, mseg_message_info_ptr, the_message_id, code);
	     if code ^= 0 then call abort_single_request (code, local_pathname, "Attempting to add request.");

	     if local_rr.notify then do;		/* let the user know it worked */
		request_id = request_id_ (local_ft_request.header.msg_time);
		call notify_user ("Submitted request ^a to transfer ^a to ^a (queue ^d)", (substr (request_id, 7, 8)),
		     local_pathname, foreign_system_name, local_rr.queue);
	     end;

	     n_submitted = n_submitted + 1;		/* keep count */
	     submitted_a_request = "1"b;		/* needed by starname processor */

	     return;
%page;
/* This particular request cannot be processed, others may be OK. */

abort_single_request:
	     procedure (p_code, p_pathname, p_message);

dcl  p_code fixed binary (35) parameter;
dcl  p_pathname character (*) parameter;
dcl  p_message character (*) parameter;

dcl  code_message character (100) aligned;
dcl  notify bit (1);

		notify = "1"b;
		go to ABORT_SINGLE_JOIN;

abort_single_request_no_notify:
	     entry (p_code, p_pathname, p_message);

		notify = "0"b;

ABORT_SINGLE_JOIN:
		if have_starname			/* there might be others that we can do */
		then do;
		     if p_code ^= NO_ERROR then
			call convert_status_code_ (p_code, shortinfo, code_message);
		     else code_message = "";

		     if notify then
			call notify_user ("Request not submitted: ^[^a^/^2x^;^s^]^a^/^2x(^a)", (p_code ^= NO_ERROR),
			     code_message, p_message, p_pathname);

		     n_not_submitted = n_not_submitted + 1;
						/* count unsuccessful tries */
		     reported_error = "1"b;		/* so we'll know not to do it later */
		     go to PROCESS_NEXT_STAR_ENTRY;	/* non-local goto into submit_request */
		end;

		else if notify then call reject_request (p_code, p_message);
		else call reject_request_no_notify (p_code, p_message);

	     end abort_single_request;
%page;
set_dir_s_error_message:
	     proc (p_idx);

dcl  p_idx fixed binary parameter;

		if code = error_table_$moderr | code = error_table_$user_not_found then
		     call ioa_$rsnnl (
			"^[Driver^;User^] (^a) must have an explicit ACL entry of S to parent directory of object.",
			local_error_message, ignore_fb21, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name)
			;
		else call ioa_$rsnnl (
			"Unable to determine access of ^[driver^;user^] (^a) to the parent directory of object.",
			local_error_message, ignore_fb21, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name)
			;

	     end set_dir_s_error_message;
%skip (4);
set_dir_sma_error_message:
	     proc (p_idx);

dcl  p_idx fixed binary parameter;

		reported_dir_sma_warning = "1"b;	/* don't want to come through here again */
						/* for current star name */
		if code = error_table_$moderr | code = error_table_$user_not_found then
		     call ioa_$rsnnl (
			"Warning: ^[Driver^;User^] (^a) must have an explicit ACL entry of SMA to parent directory of object to be deleted.^/^2xRequest will still be submitted.^/^2x(^a)",
			local_error_message, ignore_fb21, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name,
			local_pathname);
		else do;
		     call convert_status_code_ (code, shortinfo, code_message);
		     call ioa_$rsnnl (
			"Warning: ^a^/^2xUnable to determine access of ^[driver^;user^] (^a) to the parent directory of object to be deleted.^/^2xRequest will still be submitted.^/^2x(^a)",
			local_error_message, ignore_fb21, code_message, (p_idx = DRIVER_ACL_IDX),
			general_acl (p_idx).access_name, local_pathname);
		end;

	     end set_dir_sma_error_message;

	end process_single_request;

     end submit_request;
%page;
/* Reject the transfer request: send a reply to the remote system indicating the reason for the failure */

reject_request:
     procedure (p_code, p_message);

dcl  p_code fixed binary (35) parameter;
dcl  p_message character (*) parameter;

dcl  code_message character (100) aligned;
dcl  send_to_user bit (1);

	send_to_user = "1"b;
	go to REJECT_JOIN;

reject_request_no_notify:
     entry (p_code, p_message);

	send_to_user = "0"b;

REJECT_JOIN:
	if p_code ^= NO_ERROR then
	     call convert_status_code_ (p_code, shortinfo, code_message);
	else code_message = "";

	local_bof_reply.abort_request = "1"b;		/* tell remote system to not send it */
	local_bof_reply.abort_message = rtrim (code_message) || " " || p_message;

	if send_to_user then
	     call notify_user (REQ_TERMED_STR, p_code ^= 0, code_message, p_message, local_full_pathname);

	call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "**Request ^d: ^a ^a", local_request_number, code_message, p_message)
	     ;

	local_icri.version = ICRI_VERSION_1;
	local_icri.timeout = 5 * ONE_MINUTE;
	local_icri.record_type = IMFT_BOF;		/* this is a reply to their BOF command */
	local_icri.record_ptr = addr (local_bof_reply);
	local_icri.record_lth = 4 * currentsize (local_bof_reply);

	call iox_$control (data_iocb_ptr, "write_reply_record", addr (local_icri), code);
	if code ^= 0 then call io_error (code, "Attempting to reply to " || foreign_system_name || ".");

	call cleanup_handler ();			/* cleanup after this one */

	go to WAIT_FOR_NEXT_OBJECT;

     end reject_request;
%page;
/* Abort receiving an object */

abort_reception:
     procedure (p_code, p_message);

dcl  p_code fixed binary (35) parameter;
dcl  p_message character (*) parameter;

dcl  code_message character (100) aligned;

	if p_code ^= 0 then
	     call convert_status_code_ (p_code, shortinfo, code_message);
	else code_message = "";

	call notify_user ("Request for ^a terminated: ^a ^a", local_full_pathname, code_message, p_message);

	call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "**Request ^d: ^a ^a", local_bof_command.request_number,
	     code_message, p_message);

	call cleanup_handler ();			/* cleanup after it */

	go to WAIT_FOR_NEXT_OBJECT;

     end abort_reception;
%skip (4);
/**** Unable to communicate with imft_util_$check_object_acl with current version of imft_check_acl structure. */

fatal_ica_error:
     procedure ();

	P_code = code;
	call iodd_msg_ (NORMAL, MASTER, NO_ERROR, IMFT_RECEIVE_OBJECT_,
	     "Invalid imft_check_acl version error from call to imft_util_$check_object_acl.");
	go to RETURN_FROM_RECEIVE_OBJECT;

     end fatal_ica_error;
%page;
/* Respond to an I/O error on the line: return to command level */

io_error:
     procedure (p_io_code, p_message);

dcl  p_io_code fixed binary (35) parameter;
dcl  p_message character (*) parameter;

dcl  code_message character (100) aligned;

	if object_in_progress & local_bof_command.notify then do;
	     if p_io_code ^= 0 then			/* let the user know */
		call convert_status_code_ (p_io_code, shortinfo, code_message);
	     else code_message = "";
	     call notify_user ("Request for ^a terminated: ^a ^a", local_full_pathname, code_message, p_message);
	end;

	call iodd_msg_ (ERROR, MASTER, p_io_code, IMFT_RECEIVE_OBJECT_, "^a", p_message);

	P_code = p_io_code;				/* reflect to the driver which will reinitialize */

	if imft_driver_info.debug_mode & (p_io_code ^= imft_et_$timeout) then signal condition (imft_debug_);
						/* give programmer a look: timeouts are handled by imft_io_ */

	go to RETURN_FROM_RECEIVE_OBJECT;

     end io_error;
%skip (4);
/* Send a notification to the user */

notify_user:
     procedure () options (variable);

dcl  notify_msg character (notify_msg_buffer_used) based (addr (notify_msg_buffer));
dcl  notify_msg_buffer_used fixed binary (21);

	call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, notify_msg_buffer, notify_msg_buffer_used, "0"b, "1"b);

	call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, INTERACTIVE_DELIVERY, "",
	     notify_msg, mail_access_class, ignore_code);

	return;

     end notify_user;
%page;
/*
   Analyze results of using backup_load_: assumes any possible errors will be reflected both in the error file and return
   code from the backup_load_ call
*/

analyze_backup_results:
     procedure (P_code);

dcl  P_code fixed binary (35) parameter;		/* return from backup_load_ */

dcl  errfile_bc fixed binary (24);
dcl  backup_code fixed binary (35);
dcl  backup_message character (20) varying;

	backup_errors_detected = "0"b;		/* until proven otherwise */

	if ^imft_driver_info.old_version then
	     foreign_backup_errors = eof_command.backup_errors;
	else foreign_backup_errors = "0"b;

	call ios_$detach ("err_file", "", "", ios_status);

	call hcs_$initiate_count (errfile_dname, errfile_ename, "", errfile_bc, 00b, errfile_ptr, ignore_code);

	if errfile_ptr ^= null () then		/* there is an error file there */
	     if errfile_bc ^= 0 then			/* it's not empty: something went wrong */
		call report_backup_errors ();

	     else do;				/* no error file, but make sure reload really worked */
		if ^static_backup_control.object.found	/* didn't find anything with the right name */
		then do;
		     backup_code = error_table_$noentry;
		     backup_message = "not received from";
		     call notify_backup_failure ();
		end;

		else if ^static_backup_control.object.loaded
						/* found it, but couldn't load it */
		then do;
		     backup_code = static_backup_control.object.status_code;
						/* hopefully this will be something informative */
		     backup_message = "not loaded from";
		     call notify_backup_failure ();
		end;

		else if foreign_backup_errors then
		     call notify_user ("Errors in transmission of ^a; see your mail at ^a.", local_full_pathname,
			foreign_system_name);
	     end;

	call hcs_$truncate_file (errfile_dname, errfile_ename, 0, ignore_code);
	call hcs_$set_bc (errfile_dname, errfile_ename, 0, ignore_code);

	errfile_attached = "0"b;

	return;
%page;
/* Internal to analyze_backup_results: reports errors detected by backup_load_ and recorded in the error file */

report_backup_errors:
	procedure ();

dcl  error_file character (errfile_lth) based (errfile_ptr);
dcl  errfile_lth fixed binary (21);
dcl  mail_subject character (1024) varying;

	     backup_errors_detected = "1"b;		/* let top-level know not to notify */

	     errfile_lth = divide ((errfile_bc + 8), 9, 21, 0);

	     call ioa_$rsnnl ("Received^[ extension to^]^[ update to^] ^a ^a with errors from ^a (queue ^d)",
		mail_subject, ignore_fb21, local_bof_command.extend, local_bof_command.update,
		OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name,
		local_bof_command.queue);

	     call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, ORDINARY_DELIVERY,
		(mail_subject), error_file, mail_access_class, ignore_code);

	     return;

	end report_backup_errors;


/* Internal to analyze_backup_results: reports failure of backup when no error file present */

notify_backup_failure:
	procedure ();

dcl  code_message character (100) aligned;
dcl  (mail_subject, mail_message) character (1024) varying;

	     call convert_status_code_ (backup_code, shortinfo, code_message);
	     call ioa_$rsnnl ("^a^/^a ^a ^a (queue ^d).^/^a", mail_message, ignore_fb21, code_message,
		local_full_pathname, backup_message, foreign_system_name, local_bof_command.queue,
		static_backup_control.object.error_name);

	     call ioa_$rsnnl ("Received^[ extension to^]^[ update to^] ^a ^a with errors from ^a (queue ^d)",
		mail_subject, ignore_fb21, local_bof_command.extend, local_bof_command.update,
		OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name,
		local_bof_command.queue);

	     call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, ORDINARY_DELIVERY,
		(mail_subject), (mail_message), mail_access_class, ignore_code);

	     backup_errors_detected = "1"b;
	     return;

	end notify_backup_failure;

     end analyze_backup_results;
%page;
/* Represents the null entry value: if called, the current object is aborted */

nulle:
     procedure () options (variable);

	call abort_reception (NO_ERROR, "Backup system requested tape label.");

	return;

     end nulle;
%page;
/* Parameters */

dcl  P_imft_driver_info_ptr pointer parameter;		/* -> description of the IMFT driver */
dcl  P_fis_info_ptr pointer parameter;			/* -> list of I/O switches: 1st is master terminal; 2nd is the
						   connection to the remote system */
dcl  P_code fixed binary (35) parameter;

/* Remaining declarations */

dcl  data_iocb_ptr pointer;				/* -> I/O switch for file transmission */
dcl  master_iocb_ptr pointer;				/* -> I/O switch for master console */

dcl  code fixed binary (35);
dcl  idx fixed binary;
dcl  ignore_code fixed binary (35);
dcl  ignore_fb21 fixed binary (21);

dcl  1 local_icri aligned like icri automatic;
dcl  1 local_bof_command aligned like bof_command;
dcl  1 local_bof_reply aligned like bof_reply;
dcl  1 local_eof_reply aligned like eof_reply;
dcl  1 local_rr aligned like remote_request;

dcl  1 imft_chk_acl aligned like imft_check_acl;

dcl  1 ios_status aligned,				/* for calling ios_$* */
       2 code fixed binary (35),			/* actual error code */
       2 io_status bit (36);				/* status bits from last I/O operation */

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  code_message char (100) aligned;
dcl  input_buffer character (2048);			/* for reading commands */
dcl  notify_msg_buffer character (2048);		/* for construction of user notifications */

dcl  source fixed binary;				/* which I/O switch has input */

dcl  errfile_ptr pointer;				/* -> error file generated by backup */
dcl  errfile_attached bit (1) aligned;			/* ON => error file is setup */

dcl  object_in_progress bit (1) aligned;		/* ON => something is being received: inform user on abort */
dcl  backup_errors_detected bit (1) aligned;		/* ON => some errors occured in backup_load_ */
dcl  foreign_backup_errors bit (1) aligned;		/* ON => error reported in backup_dump_ by foreign system */

dcl  (mail_destination, local_personid) character (32);
dcl  mail_access_class bit (72) aligned;

dcl  (local_full_pathname, local_dirname, foreign_full_pathname) character (168);
dcl  foreign_system_name character (32) varying;
dcl  local_entname character (32);
dcl  local_request_number fixed binary (35);
dcl  local_starname character (32);
dcl  local_type character (32);
dcl  foreign_equalname character (168);
dcl  octal_string character (32) aligned;

dcl  my_group_id character (32);
dcl  my_user_id character (30);
dcl  (foreign_user_id, local_user_id) character (32) varying;
dcl  shortinfo character (8) aligned;
dcl  user_ring fixed binary (3);
dcl  local_user_access_id character (32);
dcl  (acs_write_bracket, current_ring) fixed binary (3);

dcl  n_submitted fixed binary;
dcl  n_not_submitted fixed binary;

dcl  IMFT_RECEIVE_OBJECT_ character (32) static options (constant) initial ("imft_receive_object_");
dcl  ONE_MINUTE fixed binary static options (constant) initial (60);
dcl  NO_ERROR fixed binary (35) initial (0) static options (constant);
dcl  NO_OBJ_FND_SATISFY_REQ_STR character (42) initial ("No objects were found to satisfy request.") internal
	static options (constant);
dcl  REQ_TERMED_STR character (54) initial ("Request terminated: ^[^a^/^2x^;^s^]^a^/^2x(^a)") internal static
	options (constant);
dcl  first_call bit (1) aligned static initial ("1"b);

dcl  1 static_backup_control aligned static,		/* control structure for backup_load_ */
       2 header like backup_control.header,		/* ... global data */
       2 object like backup_control.requests;		/* ... the actual object to be reloaded */

dcl  1 branch_info aligned int static like create_branch_info;
dcl  1 cpo aligned like copy_options;

dcl  errfile_dname character (168) static;		/* name of scratch file used as error file */
dcl  errfile_ename character (32) static;
dcl  errfile_pathname character (168) static;
dcl  temp_ename character (32) static;
dcl  temp_dname character (168) static;

dcl  error_table_$ai_restricted fixed bin (35) ext static;
dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  error_table_$fatal_error fixed bin (35) ext static;
dcl  error_table_$link fixed bin (35) ext static;
dcl  error_table_$moderr fixed bin (35) ext static;
dcl  error_table_$noentry fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed binary (35) external;
dcl  error_table_$unsupported_operation fixed bin (35) ext static;
dcl  error_table_$user_not_found fixed bin (35) ext static;

dcl  imft_et_$timeout fixed binary (35) external;

dcl  imft_data_$queue_dirname character (168) external static;

dcl  HCS_DONT_CHASE fixed binary (1) static options (constant) initial (0);

dcl  A_EXTENDED_ACCESS bit (36) aligned internal static options (constant) init ("400000000000"b3);

dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  backup_load_ entry (pointer, fixed binary (35));
dcl  check_star_name_$entry entry (char (*), fixed bin (35));
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  convert_aim_attributes_ entry (bit (72) aligned, character (32) aligned);
dcl  convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned);
dcl  copy_ entry (ptr);
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  get_authorization_ entry () returns (bit (72) aligned);
dcl  get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35));
dcl  get_group_id_ entry () returns (character (32));
dcl  get_pdir_ entry () returns (character (168));
dcl  get_ring_ entry () returns (fixed binary (3));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  hcs_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35));
dcl  hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$get_user_access_modes
	entry (char (*), char (*), char (*), fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  hcs_$initiate_count
	entry (character (*), character (*), character (*), fixed binary (24), fixed binary (2), pointer,
	fixed binary (35));
dcl  hcs_$make_seg entry (character (*), character (*), character (*), fixed binary (5), pointer, fixed binary (35));
dcl  hcs_$set_bc entry (character (*), character (*), fixed binary (24), fixed binary (35));
dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl  hcs_$terminate_noname entry (pointer, fixed binary (35));
dcl  hcs_$truncate_file entry (character (*), character (*), fixed binary (19), fixed binary (35));
dcl  iod_info_$driver_access_name entry (char (*), char (32), fixed bin (35));
dcl  imft_convert_status_code_$decode entry (fixed binary (35)) returns (fixed binary (35));
dcl  imft_find_input_switch_ entry (pointer, bit (1) aligned, fixed binary, fixed binary (35));
dcl  imft_mail_interface_$deliver_message
	entry (character (*), character (*), fixed binary, character (*), character (*), bit (72) aligned,
	fixed binary (35));
dcl  imft_pnt_interface_$validate_personid entry (character (*), fixed binary (35));
dcl  imft_util_$check_object_acl entry (ptr, fixed bin (35));
dcl  ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1));
dcl  ioa_$rsnnl entry () options (variable);
dcl  iodd_msg_ entry () options (variable);
dcl  ios_$attach entry (character (*), character (*), character (*), character (*), 1 aligned like ios_status);
dcl  ios_$detach entry (character (*), character (*), character (*), 1 aligned like ios_status);
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  message_segment_$open entry (char (*), char (*), fixed bin, fixed bin (35));
dcl  message_segment_$close entry (fixed bin, fixed bin (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  request_id_ entry (fixed bin (71)) returns (char (19));
dcl  queue_admin_$add_index entry (fixed bin, pointer, bit (72) aligned, fixed bin (35));
dcl  system_privilege_$ring1_priv_on entry (fixed binary (35));
dcl  system_privilege_$ring1_priv_off entry (fixed binary (35));
dcl  term_$refname entry (character (*), fixed binary (35));
dcl  translate_aim_attributes_ entry (pointer, bit (72) aligned, pointer, bit (72) aligned, fixed binary (35));
dcl  unique_chars_ entry (bit (*)) returns (character (15));

dcl  (cleanup, imft_debug_, imft_read_abort_, imft_remote_logout_, imft_resynchronize_driver_, linkage_error, sub_error_)
	condition;

dcl  (addr, after, before, clock, convert, currentsize, divide, hbound, index, length, max, null, rtrim, string, substr,
     sum, unspec) builtin;
%page;
%include access_mode_values;
%page;
%include acl_structures;
%page;
%include backup_control;
%page;
%include condition_info;
%page;
%include condition_info_header;
%page;
%include copy_error_info;
%page;
%include copy_flags;
%page;
%include copy_options;
%page;
%include create_branch_info;
%page;
%include fs_star_;
%page;
%include "_imft_check_acl";
%page;
%include "_imft_cri";
%page;
%include "_imft_driver_info";
%page;
%include "_imft_fis_info";
%page;
%include "_imft_ft_commands";
%page;
%include "_imft_ft_request";
%page;
%include "_imft_std_commands";
%page;
%include iodd_msg_constants;
%page;
%include mlsys_deliver_info;
%page;
%include mseg_message_info;
%page;
%include queue_msg_hdr;
%page;
%include star_structures;
%page;
%include sub_error_info;
     end imft_receive_object_;




		    imft_transmit_object_.pl1       11/14/88  1517.9rew 11/14/88  1511.2      541818



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

/* Transmit a storage system object to a remote Multics system */

/* Created:  October 1980 by G. Palter */
/* Modified: 27 February 1981 by G. Palter to better report errors from remote system and access validation errors */
/* Modified: 28 February 1981 by G. Palter to add an RQO handler to permit dumping of segments with zero pages */
/* Modified: April 1982 by G. Palter to complete initial implementation */
/* Modified: July 1982 by G. Palter for true AIM support and to properly process I/O error abort control records */
/* Modified: March 1983 by Robert Coren to check for local_io_error */
/* Modified: April 1983 by Robert Coren to implement request for remote transfer ("pull") */
/* Modified: June 1983 by Robert Coren to enforce defer_time */
/* Modified: August 1983 by Robert Coren to enforce minimum_access_class */
/* Modified: November 1983 by Robert Coren to upgrade objects to requestor's authorization */
/* Modified: February 23, 1985 by C. Marker to use version 5 message segments */

/****^  HISTORY COMMENTS:
  1) change(87-11-15,Oke), approve(88-08-01,MCR7948), audit(88-10-17,Farley),
     install(88-10-14,MR12.2-1165):
     Revise time estimation and calculation to reduce variance.  Time
     estimate is held in static to preserve it across reinits and other
     restarting occurances.
  2) change(88-06-21,Beattie), approve(88-08-01,MCR7948),
     audit(88-10-17,Farley), install(88-10-14,MR12.2-1165):
     The following changes were made.
     a. Change rate averaging to be the same as that used by do_prt_request_.
     b. Set up imft_driver_info.min_time_to_log to control "Estimated .."
        display to log.
     c. Add support for the -delete option.
     d. Add support to reject requests based on other system's driver software
        version if -extend or -update options are used.
     e. Change all access checking to look for explicit ACLs for both user and
        driver.
     f. Add access checks on all objects in a subtree if a subtree is to be
        transfered.
  3) change(88-10-21,Beattie), approve(88-08-19,MCR7911),
     audit(88-10-26,Wallman), install(88-10-28,MR12.2-1199):
     Add iod_tables_hdr.incl.pl1 to support version 5 iod tables.
  4) change(88-11-10,Beattie), approve(88-08-01,PBF7948),
     audit(88-11-14,Farley), install(88-11-14,MR12.2-1214):
     Change declaration of local_request_number to match up with what is
     coming from request_descriptor structure to prevent size condtions.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */

imft_transmit_object_:
     procedure (P_data_iocb_ptr, P_stat_p, P_imft_driver_info_ptr, P_code);

	system_area_ptr = get_system_free_area_ ();

/**** One time initialization */

	if first_call then do;
	     process_dname = get_pdir_ ();		/* place for access checking errors */
	     accessfile_ename = "IMFT.access." || unique_chars_ (""b);
	     accessfile_path = pathname_ (process_dname, accessfile_ename);
	     call hcs_$make_seg (process_dname, accessfile_ename, "", RW_ACCESS_BIN, accessfile_ptr, code);
	     if accessfile_ptr = null () then do;	/* shouldn't happen, but... */
		call iodd_msg_ (code, MASTER, "Creating ^a to hold access check errors.", accessfile_path);
		return;
	     end;
	     call hcs_$terminate_noname (accessfile_ptr, ignore_code);

	     process_dname = get_pdir_ ();		/* create error file for notifications */
	     errfile_ename = "IMFT." || unique_chars_ (""b);
	     errfile_pathname = pathname_ (process_dname, errfile_ename);
	     call hcs_$make_seg (process_dname, errfile_ename, "", 01010b, errfile_ptr, code);
	     if errfile_ptr = null () then do;		/* shouldn't happen, but... */
		call iodd_msg_ (ERROR, MASTER, code, IMFT_TRANSMIT_OBJECT_,
		     "Creating ^a as error file for notifications.", errfile_pathname);
		P_code = code;
		return;
	     end;
	     call hcs_$terminate_noname (errfile_ptr, ignore_code);

	     first_call = "0"b;			/* all set */
	end;					/* if first_call */
	else do;
	     call hcs_$truncate_file (process_dname, accessfile_ename, 0, ignore_code);
	     call hcs_$set_bc (process_dname, accessfile_ename, 0, ignore_code);
	end;

/**** Setup for operation */

	data_iocb_ptr = P_data_iocb_ptr;
	stat_p = P_stat_p;
	imft_driver_info_ptr = P_imft_driver_info_ptr;
	P_code = 0;

	foreign_system_name = rtrim (imft_driver_info.foreign_system.name);
	foreign_system_version = convert (foreign_system_version, imft_driver_info.foreign_system.imft_version);

	ds_ptr = iodd_static.driver_ptr;
	rd_ptr = addr (ds_ptr -> driver_status.descriptor);
	mseg_message_info_ptr = addr (rd_ptr -> request_descriptor.mseg_message_info_copy);
	ft_request_ptr = addr (ds_ptr -> driver_status.message);

	acl_ptr, afs_ptr, errfile_ptr = null ();	/* keeps cleanup handler happy */
	errfile_attached, send_abort_command = "0"b;

	my_group_id = get_group_id_ ();		/* Person.Project.Tag for access checking */
	current_ring = get_ring_ ();

	on condition (cleanup) call cleanup_handler ();

	abort_request_label = ABORT_REQUEST;		/* for driver's unclaimed signal handler */

/**** Build local description of request */

	local_notify = ft_request.notify;
	local_request_number = rd_ptr -> request_descriptor.seq_id;

	if ft_request.remote_transfer then do;

/**** Set up remote to local transfer request. */

	     unspec (local_rr) = ""b;
	     local_rr.priority_request = rd_ptr -> request_descriptor.priority_request;
	     local_rr.queue = rd_ptr -> request_descriptor.q;
	     local_rr.request_number = rd_ptr -> request_descriptor.seq_id;

	     local_rr.notify = ft_request.notify;

	     local_rr.local_user =
		substr (mseg_message_info.sender_id, 1, (length (rtrim (mseg_message_info.sender_id)) - 2));
	     local_rr.local_user_authorization = mseg_message_info.sender_authorization;
	     local_rr.local_user_ring = mseg_message_info.sender_level;

	     mail_destination = local_rr.local_user;	/* user to receive notifications at this end */
	     mail_access_class = local_rr.local_user_authorization;
	     local_rr.request_info = ft_request;
	     source_full_pathname = pathname_ ((ft_request.dirname), (ft_request.ename));
	     if ft_request.foreign_path_given then
		target_full_pathname = pathname_ (ft_request.foreign_dirname, ft_request.foreign_ename);
	     else target_full_pathname = source_full_pathname;

	     if ((ft_request.extend | ft_request.update) & foreign_system_version < 4.0) then do;
		call ioa_$rsnnl ("Driver on ^a system does not support the ^[-extend^;-update^] option.",
		     abort_message, ignore_fb21, foreign_system_name, ft_request.extend);
		call abort_request_notify (FLUSH_REQUEST, error_table_$unimplemented_version, abort_message);
	     end;

	     call iodd_msg_ (LOG, MASTER, NO_ERROR, "",
		"Request ^d ^a output q^d: receive^[ extension to^]^[ update to^] ^a^/^2xfor ^a^[ from ^a^;^s^]^[^/^2xoriginally ^a^]",
		local_rr.request_number, foreign_system_name, local_rr.queue, local_rr.extend, local_rr.update,
		target_full_pathname, local_rr.local_user, local_rr.foreign_user_given, local_rr.foreign_user,
		local_rr.foreign_path_given, source_full_pathname);

	     if (local_rr.notify | ((foreign_system_version < 4.0) & local_rr.delete)) then
		call notify_user (
		     "Requesting transfer of ^a from ^a (queue ^d)^[ even though driver on the other system does not support deletion of objects^].",
		     source_full_pathname, foreign_system_name, local_rr.queue,
		     ((foreign_system_version < 4.0) & local_rr.delete));

	     local_icri.record_type = IMFT_REMOTE_REQUEST;
	     local_icri.record_ptr = addr (local_rr);
	     local_icri.record_lth = 4 * currentsize (local_rr);
	end;

	else do;

/**** Set up local transfer to remote */

	     unspec (local_bof_command) = ""b;

	     local_bof_command.continued = rd_ptr -> request_descriptor.continued;
	     local_bof_command.restarted = rd_ptr -> request_descriptor.restarted;
	     local_bof_command.priority_request = rd_ptr -> request_descriptor.priority_request;
	     local_bof_command.queue = rd_ptr -> request_descriptor.q;
	     local_bof_command.request_number = rd_ptr -> request_descriptor.seq_id;

	     local_bof_command.notify = ft_request.notify;
	     local_bof_command.local_dirname = ft_request.dirname;
	     local_bof_command.local_ename = ft_request.ename;
						/* pathname of object on local system */
	     local_full_pathname = pathname_ (local_bof_command.local_dirname, local_bof_command.local_ename);

	     local_bof_command.local_user =
		substr (mseg_message_info.sender_id, 1, (length (rtrim (mseg_message_info.sender_id)) - 2));
	     local_bof_command.local_user_authorization = mseg_message_info.sender_authorization;
	     local_bof_command.local_user_ring = mseg_message_info.sender_level;

	     mail_destination = local_bof_command.local_user;
						/* user to receive notifications at this end */
	     mail_access_class = local_bof_command.local_user_authorization;

	     local_bof_command.foreign_system = ft_request.request;

	     if local_bof_command.foreign_path_given then
		foreign_full_pathname =
		     pathname_ (local_bof_command.foreign_dirname, local_bof_command.foreign_ename);
	     else foreign_full_pathname = local_full_pathname;
						/* same pathname wanted on both systems */

	     if ((ft_request.extend | ft_request.update) & foreign_system_version < 4.0) then do;
		call ioa_$rsnnl ("Driver on ^a system does not support the ^[-extend^;-update^] option.",
		     abort_message, ignore_fb21, foreign_system_name, ft_request.extend);
		call abort_request_notify (FLUSH_REQUEST, error_table_$unimplemented_version, abort_message);
	     end;


/**** Validate that the object exists */

	     call hcs_$status_minf (local_bof_command.local_dirname, local_bof_command.local_ename, 0b,
		local_bof_command.object_type, local_bit_count, code);
	     if code ^= 0 then do;
		call iodd_msg_ (LOG, MASTER, NO_ERROR, "",
		     "Request ^d ^a output q^d:  transmit^[ extension object^]^[ update object^] ^a^/^2xfrom ^a^[ for ^a^;^s^]^[^/^2xas ^a^]",
		     local_bof_command.request_number, foreign_system_name, local_bof_command.queue,
		     local_bof_command.extend, local_bof_command.update, local_full_pathname,
		     local_bof_command.local_user, local_bof_command.foreign_user_given,
		     local_bof_command.foreign_user, local_bof_command.foreign_path_given, foreign_full_pathname);
		call abort_request_notify (FLUSH_REQUEST, code, "Determining type of object.");
	     end;

	     if local_bof_command.object_type = DIRECTORY then
						/* be sure to notice MSFs */
		if local_bit_count ^= 0 then local_bof_command.object_type = MSF;



/**** Log beginning of transmission, inform user if requested, and validate access */

	     call iodd_msg_ (LOG, MASTER, NO_ERROR, "",
		"Request ^d ^a output q^d: transmit^[ extension^]^[ update^] ^a ^a^/^2xfrom ^a^[ for ^a^;^s^]^[^/^2xas ^a^]",
		local_bof_command.request_number, foreign_system_name, local_bof_command.queue,
		local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type),
		local_full_pathname, local_bof_command.local_user, local_bof_command.foreign_user_given,
		local_bof_command.foreign_user, local_bof_command.foreign_path_given, foreign_full_pathname);

	     if local_bof_command.object_type = LINK then
		call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "Object to be transmitted can not be a link.");

	     allow_delete = "1"b;			/* until proven otherwise */
	     call validate_access ();			/* doesn't return if access isn't OK */

	     call estimate_time (object_length, time_needed_to_transmit);
	     time_pict = float (time_needed_to_transmit) / float (ONE_MINUTE);
	     if ds_ptr -> driver_status.defer_time_limit > 0
						/* should we be checking against time limit? */
		then
		if time_needed_to_transmit > ds_ptr -> driver_status.defer_time_limit then
		     call abort_request_notify (KEEP_REQUEST, NO_ERROR,
			"Request deferred automatically because it would exceed time limit. (estimated time "
			|| time_pict || " minutes.)");

	     if local_bof_command.notify then
		call notify_user (
		     "Beginning transmission of^[ extension^]^[ update^] ^a ^a to ^a (queue ^d). Estimated time: ^.1f minutes.",
		     local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type),
		     local_full_pathname, foreign_system_name, local_bof_command.queue,
		     float (time_needed_to_transmit) / float (ONE_MINUTE));


/**** Establish handlers for various error conditions which might arise */

	     on condition (daemon_again), condition (daemon_again_slave)
		begin;				/* restart current request */
		if send_abort_command then		/* need to cleanup after ourselves */
		     call write_abort_command (IMFT_ABORT_RESTARTED, 0);
		call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "Restarting request.");
		go to RESTART_THIS_REQUEST;
	     end;

	     on condition (daemon_save)
		begin;				/* save this request */
		if send_abort_command then		/* started doing something */
		     call write_abort_command (IMFT_ABORT_SAVED, 0);
		call cleanup_handler ();		/* cleanup the mess */
	     end;

	     on condition (daemon_defer)
		begin;				/* operator request deferral */
		if send_abort_command then		/* indicate what happened */
		     call write_abort_command (IMFT_ABORT_DEFERRED, 0);
		call abort_request (KEEP_REQUEST, NO_ERROR, "Operator deferred request until a later time.");
	     end;

	     on condition (daemon_cancel), condition (daemon_kill)
		begin;				/* operator has cancelled request */
		if send_abort_command then		/* explain to foreign system */
		     call write_abort_command (IMFT_ABORT_CANCELLED, 0);
		call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "Operator cancelled the request.");
	     end;

	     on condition (imft_write_abort_) call analyze_write_abort;

	     iodd_static.request_in_progress = "1"b;	/* as of now, it's running */

	     go to START_REQUEST;			/* get the ball started */


/**** Control arrives here to RESTART the current request */

RESTART_THIS_REQUEST:
	     local_bof_command.continued = "1"b;	/* looks like it's being continued */

/**** Control arrives here to START the current request */

/****
      Prepare to invoke backup_dump_: construct description of the dump and terminate the backup system to cleanup from last
      use in this process (if any)
*/

START_REQUEST:
	     call estimate_time (object_length, time_needed_to_transmit);
	     time_pict = float (time_needed_to_transmit) / float (ONE_MINUTE);
	     if ds_ptr -> driver_status.defer_time_limit > 0
						/* should we be checking against time limit? */
		then
		if time_needed_to_transmit > ds_ptr -> driver_status.defer_time_limit then
		     call abort_request_notify (KEEP_REQUEST, NO_ERROR,
			"Request deferred automatically after restart because it would exceed time limit. (estimated time "
			|| time_pict || " minutes.)");

/**** All set to transmit. */

	     if time_needed_to_transmit > imft_driver_info.min_time_to_log then
		call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2xEstimated time: ^.1f minutes.",
		     float (time_needed_to_transmit) / float (ONE_MINUTE));

	     static_backup_control.version = BACKUP_CONTROL_VERSION_5;
	     static_backup_control.tape_entry = nulle;

	     string (static_backup_control.options) = ""b;
	     static_backup_control.debug_sw = "1"b;
	     static_backup_control.error_file = "1"b;
	     static_backup_control.caller_handles_conditions = "1"b;

	     static_backup_control.preattached = "1"b;	/* we supply the I/O switch */
	     static_backup_control.data_iocb = data_iocb_ptr;

	     static_backup_control.enforce_max_access_class = "1"b;
	     static_backup_control.maximum_access_class = imft_driver_info.local_system.access_ceiling;
						/* nothing higher than this class is dumped */
	     static_backup_control.enforce_min_access_class = "1"b;
	     static_backup_control.minimum_access_class = imft_driver_info.local_system.access_floor;
						/* nothing lower than this class is dumped */

	     static_backup_control.dont_dump_upgraded_dirs = "1"b;
	     static_backup_control.maximum_dir_access_class = local_bof_command.object_access_class;
						/* don't dump any upgraded directories */

	     static_backup_control.check_effective_access = "1"b;
	     static_backup_control.user_for_access_check.id = rtrim (local_bof_command.local_user) || ".*";
	     static_backup_control.user_for_access_check.authorization = local_bof_command.local_user_authorization;
	     static_backup_control.user_for_access_check.ring = local_bof_command.local_user_ring;
						/* don't dump it if the user can't access it either */
	     static_backup_control.upgrade_to_user_auth = "1"b;
						/* don't allow creation of objects at lower level than user's */
						/* authorization */

	     static_backup_control.request_count = 1;	/* one and only one object to dump */

	     static_backup_control.object.path = local_full_pathname;
	     static_backup_control.object.new_path = "";
	     string (static_backup_control.object.switches) = ""b;
	     static_backup_control.object.no_primary_sw = "1"b;

	     call term_$refname ("backup_dump_", ignore_code);
	     call term_$refname ("backup_map_", ignore_code);
	     call term_$refname ("bk_ss_", ignore_code);

	     call ios_$attach ("err_file", "file", errfile_pathname, "w", ios_status);
	     if ios_status.code ^= 0 then		/* not the user's fault */
		call abort_request (KEEP_REQUEST, ios_status.code, "Setting up backup error file.");
	     errfile_attached = "1"b;			/* got one */


/**** Send a BOF command to inform the remote system that we have a file/subtree ready for transmission */

	     local_icri.record_type = IMFT_BOF;
	     local_icri.record_ptr = addr (local_bof_command);
	     local_icri.record_lth = 4 * currentsize (local_bof_command);
	end;					/* if ^ft_request.remote_transfer */

	local_icri.version = ICRI_VERSION_1;
	local_icri.timeout = 5 * ONE_MINUTE;

	call iox_$control (data_iocb_ptr, "write_command_record", addr (local_icri), code);
	if code ^= 0 then				/* something's wrong */
	     if code = imft_et_$reply_pending then do;	/* ... an unsolicited reply: analyze it */
		local_icri.record_ptr = addr (input_buffer);
		local_icri.record_max_lth = length (input_buffer);
		call iox_$control (data_iocb_ptr, "read_reply_record", addr (local_icri), code);
		if code = 0 then
		     call analyze_unsolicited_reply ();
		else call io_error (code, "Attempting to read from " || foreign_system_name || ".");
	     end;
	     else call io_error (code, "Attempting to write to " || foreign_system_name || ".");

	send_abort_command = "1"b;			/* any errors now must be reflected to the remote system */


/*
   Wait for a reply from the remote system: if the remote system rejected our BOF command, the reply will contain the
   reason in a format suitable for notifying the user
*/

	local_icri.record_ptr = addr (input_buffer);	/* a place for the reply */
	local_icri.record_max_lth = length (input_buffer);

	call iox_$control (data_iocb_ptr, "read_reply_record", addr (local_icri), code);
	if code ^= 0 then call io_error (code, "Attempting to read from " || foreign_system_name || ".");

	if local_icri.record_type = IMFT_BOF then do;	/* it's a reply to the BOF command all right ... */
	     bof_reply_ptr = addr (input_buffer);	/* ... need to know where it is */

	     if bof_reply.request_number ^= local_request_number then
		call abort_request_fatal (KEEP_REQUEST, NO_ERROR,
		     "Reply received from " || foreign_system_name || " for wrong request.");

	     else if bof_reply.abort_request then do;	/* ... didn't like our request */
		send_abort_command = "0"b;		/* ... ... no need to confuse the remote system */
		call abort_request_notify (FLUSH_REQUEST, NO_ERROR,
		     "Message from " || foreign_system_name || ": " || bof_reply.abort_message);
	     end;
	end;

	else call analyze_unsolicited_reply ();		/* weren't expecting this reply */

	if ft_request.remote_transfer			/* all we have to send is the control record */
	then do;
	     if local_rr.notify then
		call notify_user ("Transfer of ^a queued at ^a", source_full_pathname, foreign_system_name);
	     call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2x^a", bof_reply.abort_message);
	end;

	else do;					/* Transmit the file/subtree using the hierarchy dumper */

	     on condition (record_quota_overflow) ;	/* can happen on zero pages in segments being transferred */

	     time_started = clock ();
	     call backup_dump_ (addr (static_backup_control), code);
	     call iox_$control (data_iocb_ptr, "runout", null (), ignore_code);
						/* force all data out */
	     time_taken = divide (clock () - time_started, ONE_MILLION, 35, 0);
						/* get elapsed time in seconds */
	     call analyze_backup_results (code);

/****
      Send an EOF command to indicate completion of the file/subtree and notify the user if requested.
*/

	     local_icri.version = ICRI_VERSION_1;
	     local_icri.timeout = 5 * ONE_MINUTE;	/* give the other side a chance */
	     local_icri.record_type = IMFT_EOF;
	     local_icri.record_ptr = addr (local_eof_command);
	     local_icri.record_lth = 4 * currentsize (local_eof_command);

	     local_eof_command.request_number = local_request_number;
	     local_eof_command.backup_errors = backup_errors_detected | local_bof_command.delete & ^allow_delete;
						/* this will flag user at other end to */
						/* check his messages here */

	     call iox_$control (data_iocb_ptr, "write_command_record", addr (local_icri), code);
	     if code ^= 0 then			/* something's wrong */
		if code = imft_et_$reply_pending then do;
						/* ... an unsolicited reply: analyze it */
		     local_icri.record_ptr = addr (input_buffer);
		     local_icri.record_max_lth = length (input_buffer);
		     call iox_$control (data_iocb_ptr, "read_reply_record", addr (local_icri), code);
		     if code = 0 then
			call analyze_unsolicited_reply ();
		     else call io_error (code, "Attempting to read from " || foreign_system_name || ".");
		end;
		else call io_error (code, "Attempting to write to " || foreign_system_name || ".");


	     foreign_backup_errors = "0"b;
	     if ^imft_driver_info.old_version then do;	/* EOF reply will tell us whether object arrived successfully */
		local_icri.record_ptr = addr (input_buffer);
						/* a place for the reply */
		local_icri.record_max_lth = length (input_buffer);

		call iox_$control (data_iocb_ptr, "read_reply_record", addr (local_icri), code);
		if code ^= 0 then call io_error (code, "Attempting to read from " || foreign_system_name || ".");

		if local_icri.record_type = IMFT_EOF then do;
						/* it's a reply to the EOF command all right ... */
		     eof_reply_ptr = addr (input_buffer);
						/* ... need to know where it is */

		     if eof_reply.request_number ^= local_request_number then
			call abort_request_fatal (KEEP_REQUEST, NO_ERROR,
			     "Reply received from " || foreign_system_name || " for wrong request.");

		     if eof_reply.error		/* foreign system wasn't happy */
		     then do;
			call notify_user ("Errors in reception of ^a; See your messages at ^a.",
			     local_full_pathname, foreign_system_name);
			foreign_backup_errors = "1"b;
		     end;
		end;

		else call analyze_unsolicited_reply ();

/**** Update time estimate after transmission has been validated. */

		if time_taken > MINIMUM_TIME_TO_AVERAGE /* did it take long enough not to be lost in noise? */
		     then
		     call revise_time_estimate (object_length);
	     end;

	     if local_bof_command.delete & allow_delete & ^backup_errors_detected & ^foreign_backup_errors then do;
		unspec (delete_options) = ""b;
		delete_options.force = "1"b;
		delete_options.directory = "1"b;
		delete_options.segment = "1"b;
		delete_options.link = "1"b;
		deleting_object = "1"b;
		call delete_$path (local_bof_command.local_dirname, local_bof_command.local_ename,
		     string (delete_options), "", code);
		deleting_object = "0"b;
		if code ^= 0 then do;
		     call convert_status_code_ (code, shortinfo, code_message);
		     call notify_user ("Error occured while attempting to delete ^a^/(^a)", local_full_pathname,
			code_message);
		end;
	     end;

RESUME_AFTER_DELETE:
	     if local_bof_command.notify then		/* made it ... */
		if ^backup_errors_detected & ^foreign_backup_errors then
						/* ... and user not informed because of backup errors */
		     call notify_user ("Transmitted^[ extension^]^[ update^] ^a ^a without errors to ^a (queue ^d).",
			local_bof_command.extend, local_bof_command.update,
			OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name,
			local_bof_command.queue);

	     if backup_errors_detected | foreign_backup_errors | local_bof_command.delete & ^allow_delete then do;
		call iodd_msg_ (LOG, MASTER, NO_ERROR, "",
		     "^2xNonfatal errors in transfer detected at ^[^a^;^s^]^[ and ^]^[^a^].",
		     backup_errors_detected | local_bof_command.delete & ^allow_delete,
		     imft_driver_info.local_system.name, backup_errors_detected & foreign_backup_errors,
		     foreign_backup_errors, foreign_system_name);

		if local_bof_command.delete then
		     call notify_user ("Unable to delete ^a ^a due to access errors at ^a.",
			OBJECT_TYPES (local_bof_command.object_type), local_full_pathname,
			imft_driver_info.local_system.name);
	     end;

	     call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2xTransmitted request ^d.", local_request_number);

	end;					/* if ^ft_request.remote_transfer */

	send_abort_command = "0"b;			/* all done with this request */

	rd_ptr -> request_descriptor.keep_in_queue = "0"b;/* done with it */


/**** Cleanup and return to caller */

RETURN_FROM_TRANSMIT_OBJECT:
	call cleanup_handler ();			/* clean things up */

	rd_ptr -> request_descriptor.dont_delete = "1"b;	/* delete done in driver */
	rd_ptr -> request_descriptor.finished = "1"b;	/* all done */
	iodd_static.request_in_progress = "0"b;

	return;



/*
   Abort the request:  The entry is called from the driver's any_other handler if an unexpected condition is detected
   during processing of a request
*/

abort_running_request:
     entry (P_condition_name);

	condition_name = P_condition_name;

	go to abort_request_label;			/* unwind the stack */


ABORT_REQUEST:
	if deleting_object then do;
	     deleting_object = "0"b;
	     call notify_user ("The ""^a"" condition was signalled during the deletion of object,^/^a.", condition_name,
		local_full_pathname);
	     go to RESUME_AFTER_DELETE;
	end;
	else call abort_request_notify (FLUSH_REQUEST, NO_ERROR,
		"""" || rtrim (condition_name) || """ condition occurred during processing of request.");
%page;
/*
   Handler for imft_write_abort_:  This condition is raised during writing of backup records because of an I/O error or an
   unsolicited reply from the remote system
*/

analyze_write_abort:
     procedure ();

	local_icri.version = ICRI_VERSION_1;
	local_icri.timeout = 5 * ONE_MINUTE;		/* give the remote system a chance */
	local_icri.record_ptr = addr (input_buffer);
	local_icri.record_max_lth = length (input_buffer);

	call iox_$control (data_iocb_ptr, "get_abort_info", addr (local_icri), code);
	if code ^= 0 then call io_error (code, "Attempting to read from " || foreign_system_name || ".");

	call analyze_unsolicited_reply ();

	go to RETURN_FROM_TRANSMIT_OBJECT;		/* shouldn't get here */
     end analyze_write_abort;
%page;
/**** Analyze an unexpected reply from the remote system */

analyze_unsolicited_reply:
     procedure ();

dcl  abort_code_picture picture "(9)9";

	rd_ptr -> request_descriptor.keep_in_queue = "1"b;/* not the user's fault: try this one again later */

	send_abort_command = "0"b;			/* other side caused termination: no need to acknowledge */

	if local_icri.record_type = IMFT_LOGOUT then do;
	     if local_notify then
		call notify_user ("Request for ^[^a^s^;^s^a^] deferred: ^a's input driver disconnected.",
		     ft_request.remote_transfer, source_full_pathname, local_full_pathname, foreign_system_name);
	     signal condition (imft_remote_logout_);
	end;

	else if local_icri.record_type = IMFT_RESYNCHRONIZE then do;
	     if local_notify then
		call notify_user ("Request for ^[^a^s^;^s^a^] deferred: ^a requested driver to reinitialize.",
		     ft_request.remote_transfer, source_full_pathname, local_full_pathname, foreign_system_name);
	     signal condition (imft_resynchronize_driver_);
	end;

	else if local_icri.record_type = IMFT_ABORT then do;
	     abort_command_ptr = local_icri.record_ptr;	/* an I/O error most likely */
	     if abort_command.reason = IMFT_ABORT_IO_ERROR | abort_command.reason = IMFT_ABORT_LOCAL_IO_ERROR then do;
		if abort_command.reason = IMFT_ABORT_IO_ERROR
						/* came from foreign system */
		     then
		     abort_command.code = imft_convert_status_code_$decode (abort_command.code);
		call io_error (abort_command.code, "Attempting to write to " || foreign_system_name || ".");
	     end;
	     else call abort_request_fatal (KEEP_REQUEST, NO_ERROR,
		     "Unexpected abort code " || ltrim (convert (abort_code_picture, abort_command.reason))
		     || " from " || foreign_system_name || ".");
	end;

	else call abort_request_fatal (KEEP_REQUEST, NO_ERROR, "Unexpected reply code ^d from ^a.");

     end analyze_unsolicited_reply;
%page;
/**** Cleanup after a request */

cleanup_handler:
     procedure ();

	if acl_ptr ^= null () then do;
	     free general_acl in (system_area);
	     acl_ptr = null ();
	end;

	if afs_ptr ^= null () then do;
	     call hcs_$truncate_file (process_dname, accessfile_ename, 0, ignore_code);
	     call hcs_$set_bc (process_dname, accessfile_ename, 0, ignore_code);
	     afs_ptr = null ();
	end;

	iodd_static.segptr = null ();			/* have finished with it */

	if errfile_ptr ^= null () then do;
	     call hcs_$terminate_noname (errfile_ptr, ignore_code);
	     errfile_ptr = null ();
	end;

	if errfile_attached then do;
	     call ios_$detach ("err_file", "", "", ios_status);
	     call hcs_$truncate_file (process_dname, errfile_ename, 0, ignore_code);
	     call hcs_$set_bc (process_dname, errfile_ename, 0, ignore_code);
	     errfile_attached = "0"b;
	end;

	if send_abort_command then			/* indicate the request wasn't finished */
	     call write_abort_command (IMFT_ABORT_ABORTED, 0);

	return;

     end cleanup_handler;
%page;
/**** Abort the current request */

abort_request:
     procedure (p_keep_request, p_code, p_message);

dcl  p_keep_request bit (1) aligned parameter;
dcl  p_code fixed binary (35) parameter;
dcl  p_message character (*) parameter;

dcl  (notify, fatal) bit (1) aligned;

	notify, fatal = "0"b;			/* tell user only if start of transmission message was sent */
	go to ABORT_REQUEST_COMMON;


/**** Abort the current request and reinitialize the driver */

abort_request_fatal:
     entry (p_keep_request, p_code, p_message);

	notify = "0"b;				/* tell user only if start of transmission message was sent */
	fatal = "1"b;
	go to ABORT_REQUEST_COMMON;


/**** Abort the current request and inform the user */

abort_request_notify:
     entry (p_keep_request, p_code, p_message);

	notify = "1"b;				/* tell the user no matter what */
	fatal = "0"b;


ABORT_REQUEST_COMMON:
	if send_abort_command then			/* need to report that an abort happened */
	     call write_abort_command (IMFT_ABORT_ABORTED, 0);

	if p_code ^= 0 then
	     call convert_status_code_ (p_code, shortinfo, code_message);
	else code_message = "";

	if (notify | local_notify) then		/* let them know what happened */
	     call notify_user (USER_REQ_DEF_OR_TERM, p_keep_request, p_code ^= 0, code_message, p_message,
		ft_request.remote_transfer, source_full_pathname, local_full_pathname);

	call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "**Request ^d: ^a ^a", local_request_number, code_message, p_message)
	     ;

	call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "Processing of request ^d ^[deferred^;terminated^].",
	     local_request_number, p_keep_request);

	rd_ptr -> request_descriptor.keep_in_queue = p_keep_request;

	if fatal then do;
	     P_code = error_table_$fatal_error;		/* forces the driver to reinitialize */
	     if imft_driver_info.debug_mode then	/* ... but give the programmer a look first */
		signal condition (imft_debug_);
	end;

	go to RETURN_FROM_TRANSMIT_OBJECT;

     end abort_request;
%page;
/**** Report an I/O error during the processing of a request */

io_error:
     procedure (p_io_code, p_message);

dcl  p_io_code fixed binary (35) parameter;
dcl  p_message character (*);

	if send_abort_command then			/* try to cleanup the transmission */
	     call write_abort_command (IMFT_ABORT_IO_ERROR, imft_convert_status_code_$encode (p_io_code));

	if local_notify then do;			/* they were told it started: tell them it was stopped */
	     if p_io_code ^= 0 then
		call convert_status_code_ (p_io_code, shortinfo, code_message);
	     else code_message = "";
	     call notify_user ("Processing of request ^[^a^s^;^s^a^] deferred: ^a ^a", ft_request.remote_transfer,
		source_full_pathname, local_full_pathname, code_message, p_message);
	end;

	call iodd_msg_ (ERROR, MASTER, p_io_code, IMFT_TRANSMIT_OBJECT_, "^a", p_message);

	rd_ptr -> request_descriptor.keep_in_queue = "1"b;

	P_code = p_io_code;				/* let our caller reinitiatilze the driver */

	if imft_driver_info.debug_mode & (p_io_code ^= imft_et_$timeout) then signal condition (imft_debug_);
						/* give programmer a look: timeouts are handled by imft_io_ */

	go to RETURN_FROM_TRANSMIT_OBJECT;

     end io_error;
%skip (4);
/**** Send a notification to the user */

notify_user:
     procedure () options (variable);

dcl  notify_msg character (notify_msg_buffer_used) based (addr (notify_msg_buffer));
dcl  notify_msg_buffer_used fixed binary (21);

	call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, notify_msg_buffer, notify_msg_buffer_used, "0"b, "1"b);

	call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, INTERACTIVE_DELIVERY, "",
	     notify_msg, mail_access_class, ignore_code);

	return;

     end notify_user;
%page;
/**** Write an abort command to the remote system */

write_abort_command:
     procedure (p_abort_type, p_code);

dcl  p_abort_type fixed binary parameter;
dcl  p_code fixed binary (35) parameter;

	local_abort_command.reason = p_abort_type;
	local_abort_command.code = p_code;

	local_icri.version = ICRI_VERSION_1;
	local_icri.timeout = 5 * ONE_MINUTE;		/* give it a chance to get there */
	local_icri.record_type = IMFT_ABORT;
	local_icri.record_ptr = addr (local_abort_command);
	local_icri.record_lth = 4 * currentsize (local_abort_command);

	call iox_$control (data_iocb_ptr, "write_command_record", addr (local_icri), ignore_code);

	send_abort_command = "0"b;			/* we sent it */

	return;

     end write_abort_command;
%page;
/****^
   Validates access to transfer a file/subtree:  Let SPerson.SProj be the user who is sending the file/subtree,
   let MPerson.MProj be the user who is running the daemon, and let SPath be the pathname of the file/subtree to be
   transmitted.  Then:

      (1) SPerson.SProj and MPerson.MProj must have explicit "r" access to SPath if it is a file or explicit "s"
	access if it is a subtree,

      (2) the access class of SPath must be less than or equal to the access ceiling computed by the driver, and

      (3) the access class of SPath must be less than or equal to the process authorization of SPerson.SProj.

   To perform these checks, MPerson.MProj requires explicit "s" access to the parent of SPath.

   Access to each of the individual branches within a subtree is validated here.
*/

validate_access:
     procedure () options (non_quick);			/* it has a rather large amount of automatic storage */

dcl  access_file character (accessfile_lth) based (accessfile_ptr);
dcl  local_error_message character (1024);
dcl  local_pathname character (168);
dcl  local_user_id character (32) varying;
dcl  message_len fixed bin (21);
dcl  my_user_id character (32) varying;
dcl  parent_dirname character (168);
dcl  parent_ename character (32);
dcl  transfer_ring fixed binary (3);
dcl  idx fixed binary;

	local_user_id = rtrim (local_bof_command.local_user);
	my_user_id = substr (my_group_id, 1, (length (rtrim (my_group_id)) - 2));

	acl_count = 2;
	allocate general_acl in (system_area) set (acl_ptr);
	general_acl.version = GENERAL_ACL_VERSION_1;
	general_acl.count = acl_count;
	general_acl (DRIVER_ACL_IDX).access_name = my_user_id || ".*";
	general_acl (USER_ACL_IDX).access_name = local_user_id || ".*";

	local_pathname = pathname_ (local_bof_command.local_dirname, local_bof_command.local_ename);
	transfer_ring = max (current_ring, local_bof_command.local_user_ring);

	if local_bof_command.local_dirname = ">" then
	     call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "IMFT can not transfer branches under the root.");
%page;
/**** User and driver must have explicit S access to parent directory. */

	call expand_pathname_ (local_bof_command.local_dirname, parent_dirname, parent_ename, ignore_code);

	imft_chk_acl.version = IMFT_CHECK_ACL_VERSION_1;
	imft_chk_acl.foreign_sys_name = foreign_system_name;
	imft_chk_acl.dirname = parent_dirname;
	imft_chk_acl.ename = parent_ename;
	imft_chk_acl.gen_acl_ptr = acl_ptr;
	imft_chk_acl.effective_ring = transfer_ring;
	imft_chk_acl.sys_auth_ceiling = imft_driver_info.local_system.access_ceiling;
	imft_chk_acl.sys_auth_floor = imft_driver_info.local_system.access_floor;
	imft_chk_acl.user_auth = local_bof_command.local_user_authorization;
	imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX;	/* errors are initially driver's */
	imft_chk_acl.dir_access = S_ACCESS;
	imft_chk_acl.seg_access = R_ACCESS;
	imft_chk_acl.accessfile_pathname = accessfile_path;
	imft_chk_acl.check_aim = "0"b;

	call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	if code = 0 then code = imft_chk_acl.error_code;
	if code ^= 0 then do;			/* unable to fully check access if code ^= 0 */
	     if code = error_table_$unimplemented_version then
		call abort_request_fatal (KEEP_REQUEST, code, BAD_CHK_OBJ_ACL_STR);
	     call set_dir_s_error_message (imft_chk_acl.bad_acl_idx);
	     call abort_request_notify (FLUSH_REQUEST, code, substr (local_error_message, 1, message_len));
	end;					/* if code ^= 0 */

	code = 0;
	do idx = 1 to hbound (general_acl.entries, 1);
	     if general_acl (idx).status_code ^= 0 then do;
		code = general_acl (idx).status_code;
		call convert_status_code_ (code, shortinfo, code_message);
		call set_dir_s_error_message (idx);
		call notify_user (USER_REQ_DEF_OR_TERM, FLUSH_REQUEST, code ^= 0, code_message, local_error_message,
		     ft_request.remote_transfer, source_full_pathname, local_full_pathname);
	     end;
	end;

	if code ^= 0 then
	     call abort_request (FLUSH_REQUEST, NO_ERROR, "Insufficient access to parent directory of object.");
%page;
/**** User and driver must need explicit SMA on parent directory if deletion is selected. */

	if local_bof_command.delete then do;

	     imft_chk_acl.dir_access = SMA_ACCESS;
	     imft_chk_acl.seg_access = RW_ACCESS;
	     imft_chk_acl.check_aim = "0"b;
	     imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX;	/* errors are initially driver's */

	     call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	     if code = 0 then code = imft_chk_acl.error_code;
	     if code ^= 0 then do;			/* unable to fully check access if code ^= 0 */
		if code = error_table_$unimplemented_version then
		     call abort_request_fatal (KEEP_REQUEST, code, BAD_CHK_OBJ_ACL_STR);
		call notify_dir_sma_error (imft_chk_acl.bad_acl_idx);
	     end;					/* if code ^= 0 */

	     do idx = 1 to hbound (general_acl.entries, 1);
		if general_acl (idx).status_code ^= 0 then do;
		     code = general_acl (idx).status_code;
		     call notify_dir_sma_error (idx);
		end;
	     end;

	end;					/* if local_bof_command.delete */
%page;
/**** Check access to object. */

	imft_chk_acl.dirname = local_bof_command.local_dirname;
	imft_chk_acl.ename = local_bof_command.local_ename;
	imft_chk_acl.dir_access = S_ACCESS;
	imft_chk_acl.seg_access = R_ACCESS;
	imft_chk_acl.check_aim = "1"b;
	imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX;	/* errors are initially driver's */

	call imft_util_$check_object_acl (addr (imft_chk_acl), code);
	if code = 0 then code = imft_chk_acl.error_code;
	if code ^= 0				/* error_message already contains expansion of "code" */
	then do;					/* unable to fully check access if code ^= 0 */
	     if code = error_table_$unimplemented_version then
		call abort_request_fatal (KEEP_REQUEST, code, BAD_CHK_OBJ_ACL_STR);

	     call abort_request_notify (FLUSH_REQUEST, NO_ERROR,
		(imft_chk_acl (imft_chk_acl.bad_acl_idx).error_message));
	end;

	if imft_chk_acl.type = ENTRY_TYPE_LINK then
	     call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "Object to be transmitted can not be a link.");

	code = 0;
	do idx = 1 to hbound (general_acl.entries, 1);
	     if general_acl (idx).status_code ^= 0 then do;
		code = general_acl (idx).status_code;
		call notify_user (USER_REQ_DEF_OR_TERM, FLUSH_REQUEST, "0"b, "", imft_chk_acl (idx).error_message,
		     ft_request.remote_transfer, source_full_pathname, local_full_pathname);
	     end;
	end;

	if code ^= 0 then call abort_request (FLUSH_REQUEST, NO_ERROR, "Insufficient driver or user access to object.");
%page;
	if imft_chk_acl.type = ENTRY_TYPE_DIRECTORY then do;
						/* now to check the subtree */
	     imft_chk_acl.dir_access = S_ACCESS;
	     imft_chk_acl.seg_access = R_ACCESS;
	     imft_chk_acl.check_aim = "1"b;
	     imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX;	/* errors are initially driver's */

	     call imft_util_$check_subtree_acl (addr (imft_chk_acl), code);
	     if code = 0 then code = imft_chk_acl.error_code;
	     if code ^= 0 then do;			/* unable to fully check access if code ^= 0 */
		if code = error_table_$unimplemented_version then
		     call abort_request_fatal (KEEP_REQUEST, code, "Attempted to call imft_util_$check_subtree_acl");

		call abort_request_notify (FLUSH_REQUEST, code, "Error while checking access to objects in subtree.");
	     end;

/**** All access errors are in file. */

	     call hcs_$initiate_count (process_dname, accessfile_ename, "", accessfile_bc, ignore_fb2, accessfile_ptr,
		ignore_code);
	     if accessfile_ptr ^= null then
		if accessfile_bc ^= 0 then do;
		     accessfile_lth = divide ((accessfile_bc + 8), 9, 21, 0);
		     call ioa_$rsnnl ("Access errors detected for request to ^a (queue ^d)", mail_subject,
			ignore_fb21, foreign_system_name, local_bof_command.queue);
		     call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination,
			ORDINARY_DELIVERY, (mail_subject), access_file, mail_access_class, ignore_code);
		     call hcs_$truncate_file (process_dname, accessfile_ename, 0, ignore_code);
		     call hcs_$set_bc (process_dname, accessfile_ename, 0, ignore_code);
		end;				/* if accessfile_ptr ^null and accessfile_bc ^=0 */

	     if imft_chk_acl.allow_transfer then do;
		if ^imft_chk_acl.objects_to_transfer then
		     call abort_request (FLUSH_REQUEST, NO_ERROR,
			"There is nothing to transfer due to errors detected while checking access of objects in subtree."
			);
		if imft_chk_acl.found_inner_ring_object & local_bof_command.delete then do;
		     allow_delete = "0"b;
		     call notify_user (
			"Unable to delete subtree due to presense of inner-ring objects found in subtree.^/^2x(^a)",
			local_pathname);
		end;
	     end;

	     else call abort_request (FLUSH_REQUEST, NO_ERROR,
		     "Unable to allow transfer of object due to access errors.");
	end;					/* if type = direcotry */

	local_bof_command.object_access_class = local_bof_command.local_user_authorization;
						/* this is access class it will really be sent at */

	return;
%page;
set_dir_s_error_message:
	proc (p_idx);

dcl  p_idx fixed binary parameter;

	     if code = error_table_$moderr | code = error_table_$user_not_found then
		call ioa_$rsnnl (
		     "^[Driver^;User^] (^a) must have an explicit ACL entry of S to parent directory of object.",
		     local_error_message, message_len, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name);
	     else call ioa_$rsnnl (
		     "Could not determine driver's (^a) and user's (^a) access to parent directory of object.",
		     local_error_message, message_len, my_user_id, local_user_id);

	end set_dir_s_error_message;
%skip (4);
notify_dir_sma_error:
	proc (p_idx);

dcl  p_idx fixed binary parameter;

	     call convert_status_code_ (code, shortinfo, code_message);
	     if code = error_table_$moderr | code = error_table_$user_not_found then
		call notify_user (
		     "Warning: ^[Driver^;User^] (^a) must have an explicit ACL entry of SMA to parent directory of object to be deleted.^/^2xDeletion will not be performed.^/^2x(^a)",
		     (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name, local_pathname);
	     else call notify_user (
		     "Warning: ^a^/^2xCould not determine driver's (^a) and user's (^a) access to delete object.^/^2x(^a)^/Object will not be deleted.",
		     code_message, my_user_id, local_user_id, local_pathname);
	     allow_delete = "0"b;			/* this will flag user at other end to check message here */
						/* about lack of deletion access */

	end notify_dir_sma_error;
     end validate_access;
%page;
/*
   Analyze results of using backup_dump_: assumes any possible errors will be reflected both in the error file and return
   code from the backup_dump_ call
*/

analyze_backup_results:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;		/* return from backup_dump_ */

dcl  errfile_bc fixed binary (24);

	backup_errors_detected = "0"b;		/* until proven otherwise */

	call ios_$detach ("err_file", "", "", ios_status);

	call hcs_$initiate_count (process_dname, errfile_ename, "", errfile_bc, 00b, errfile_ptr, ignore_code);

	if errfile_ptr ^= null () then		/* there is an error file there */
	     if errfile_bc ^= 0 then			/* it's not empty: something went wrong */
		call report_backup_errors ();

	call hcs_$truncate_file (process_dname, errfile_ename, 0, ignore_code);
	call hcs_$set_bc (process_dname, errfile_ename, 0, ignore_code);

	errfile_attached = "0"b;

	return;


/****
      Internal to analyze_backup_results: reports errors detected by
      backup_dump_ and recorded in the error file.
*/

report_backup_errors:
	procedure ();

dcl  error_file character (errfile_lth) based (errfile_ptr);
dcl  errfile_lth fixed binary (21);

	     backup_errors_detected = "1"b;		/* let top-level know not to notify */

	     errfile_lth = divide ((errfile_bc + 8), 9, 21, 0);

	     call ioa_$rsnnl ("Transmitted^[ extension^]^[ update^] ^a ^a with errors to ^a (queue ^d)", mail_subject,
		ignore_fb21, local_bof_command.extend, local_bof_command.update,
		OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name,
		local_bof_command.queue);

	     call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, ORDINARY_DELIVERY,
		(mail_subject), error_file, mail_access_class, ignore_code);

	     return;

	end report_backup_errors;

     end analyze_backup_results;
%page;
/****
      Subroutines for enforcing defer_time limit: one to estimate how long a given
      object will take to transmit, and another to set the estimated bit rate based
      on how long the last transfer took.
*/

estimate_time:
     procedure (length_in_bits, time_needed);

/**** returns the length in bits and expected time in seconds, factoring in overhead */

dcl  length_in_bits fixed binary (35) parameter;
dcl  time_needed fixed binary (35) parameter;

dcl  code fixed binary (35);
dcl  quota_used fixed bin (18);

	if local_bof_command.object_type = SEGMENT then do;
						/* use current length */
	     call hcs_$status_long (local_bof_command.local_dirname, local_bof_command.local_ename, 1,
		addr (auto_status_branch), null (), code);
	     if code ^= 0 & code ^= error_table_$no_s_permission then do;
CANT_GET_LENGTH:
		call iodd_msg_ (LOG, MASTER, code, "", "Could not determine length of ^a.", local_full_pathname);
		length_in_bits = 0;
		time_needed = -1;
		return;
	     end;

	     else do;
		length_in_bits = BITS_PER_RECORD * auto_status_branch.current_length;
						/* current length rather than records_used because */
						/* backup dumps zero pages */
		time_needed = divide (length_in_bits, ds_ptr -> driver_status.bit_rate_est, 35, 0) + FILE_OVERHEAD;
		return;
	     end;
	end;

	else do;
	     call hcs_$quota_read (local_full_pathname, (0), (0), (""b), (""b), (0), quota_used, code);
	     if code ^= 0 then go to CANT_GET_LENGTH;

	     length_in_bits = BITS_PER_RECORD * quota_used;
	     time_needed =
		divide (length_in_bits, ds_ptr -> driver_status.bit_rate_est, 35, 0)
		+ FILE_OVERHEAD * divide (quota_used, EST_RECORDS_PER_FILE, 18, 0);
	     return;
	end;
%page;
revise_time_estimate:
     entry (length_in_bits);

dcl  factor float bin int static options (constant) init (0.75e0);
						/* smoothing factor for rate estimate */

/****
      Uses the time taken by the segment just transmitted to revise the
      estimate of the bit rate.
*/

	old_rate = ds_ptr -> driver_status.bit_rate_est;

	if time_taken < 1				/* taking no chances */
	     then
	     new_rate = old_rate;
	else new_rate = divide (length_in_bits, time_taken, 17, 0);

	if old_rate > 0 then new_rate = fixed (old_rate * factor + new_rate * (1e0 - factor));

	ds_ptr -> driver_status.bit_rate_est = new_rate;

	return;
     end estimate_time;
%page;
/**** Represents the null entry value: if called, the current request is aborted */

nulle:
     procedure () options (variable);

	call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "Backup system requested tape label.");

	return;

     end nulle;
%page;
/* Parameters */

dcl  P_data_iocb_ptr pointer parameter;			/* -> IOCB over which file is transmitted */
dcl  P_stat_p pointer parameter;			/* -> caller's iodd_static */
dcl  P_imft_driver_info_ptr pointer parameter;		/* -> description of the IMFT driver */
dcl  P_code fixed binary (35) parameter;

dcl  P_condition_name character (*) parameter;		/* abort_running_request: condition detected */


/* Remaining declarations */

dcl  data_iocb_ptr pointer;				/* -> I/O switch for file transmission */

dcl  code fixed binary (35);
dcl  ignore_code fixed binary (35);
dcl  ignore_fb2 fixed binary (2);
dcl  ignore_fb21 fixed binary (21);
dcl  new_rate fixed binary (35);
dcl  old_rate fixed binary (35);
dcl  foreign_system_version float binary;

dcl  1 local_icri aligned like icri automatic;
dcl  1 local_bof_command aligned like bof_command;
dcl  1 local_eof_command aligned like eof_command;
dcl  1 local_abort_command aligned like abort_command;
dcl  1 local_rr aligned like remote_request;

dcl  1 ios_status aligned,				/* for calling ios_$* */
       2 code fixed binary (35),			/* actual error code */
       2 io_status bit (36);				/* status bits from last I/O operation */

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  input_buffer character (2048);			/* for reading replies */
dcl  notify_msg_buffer character (2048);		/* for construction user notifications */

dcl  ds_ptr pointer;				/* -> driver_status structure */
dcl  rd_ptr pointer;				/* -> request_descriptor for this request */

dcl  errfile_ptr pointer;				/* -> error file generated by backup */
dcl  errfile_attached bit (1) aligned;			/* ON => error file is setup */

dcl  allow_delete bit (1);				/* ON => turned off if no access to delete object */
dcl  deleting_object bit (1) static;			/* ON => in process of deleting object after transfer */
dcl  send_abort_command bit (1) aligned;		/* ON => something has been sent to foreign system */
dcl  backup_errors_detected bit (1) aligned;		/* ON => some errors occured in backup_dump_ */
dcl  foreign_backup_errors bit (1) aligned;		/* ON => foreign system reported errors in backup_load_ */

dcl  mail_destination character (32);			/* user to receive notifications */
dcl  mail_access_class bit (72) aligned;

dcl  (local_full_pathname, foreign_full_pathname) character (168);
dcl  foreign_system_name character (32) varying;
dcl  local_bit_count fixed binary (24);
dcl  source_full_pathname character (168);
dcl  target_full_pathname character (168);
dcl  local_notify bit (1) aligned;
dcl  local_request_number fixed binary (35);

dcl  time_needed_to_transmit fixed binary (35);		/* number of seconds it would take to transmit this object */
dcl  time_pict picture "zzz9v.9";			/* minutes of transmit time */
dcl  time_started fixed binary (71);			/* clock time at start of transmission */
dcl  time_taken fixed binary (35);			/* number of seconds it took to tranmsit current object */
dcl  object_length fixed bin (35);			/* length of object in bits */

dcl  1 auto_status_branch aligned like status_branch;
dcl  1 imft_chk_acl aligned like imft_check_acl;

dcl  my_group_id character (32);
dcl  current_ring fixed binary (3);

dcl  IMFT_TRANSMIT_OBJECT_ character (32) static options (constant) initial ("imft_transmit_object_");

dcl  BAD_CHK_OBJ_ACL_STR character (46) init ("Attempted to call imft_util_$check_object_acl") internal static
	options (constant);
dcl  NO_ERROR fixed binary (35) internal static options (constant) initial (0);
dcl  ONE_MINUTE fixed binary static options (constant) initial (60);
dcl  ONE_MILLION fixed binary (35) static options (constant) initial (1000000);
dcl  BITS_PER_RECORD fixed binary (35) static options (constant) initial (36 * 1024);
dcl  FILE_OVERHEAD fixed binary static options (constant) initial (10);
						/* assume 10 seconds per file */
dcl  EST_RECORDS_PER_FILE fixed binary static options (constant) initial (3);
						/* for guessing how many files there are in a */
						/* subtree based on quota */
dcl  MINIMUM_TIME_TO_AVERAGE fixed binary static options (constant) initial (30);
						/* if it took less than a half minute, don't */
						/* use it for estimate */
dcl  KEEP_REQUEST bit (1) aligned static options (constant) initial ("1"b);
						/* keep the request in the queue */
dcl  FLUSH_REQUEST bit (1) aligned static options (constant) initial ("0"b);
						/* flush the request from the queue */
dcl  USER_REQ_DEF_OR_TERM character (73)
	init ("Request ^[deferred^;terminated^]: ^[^a^/^2x^;^s^]^a^/^2x(^[^a^s^;^s^a^])") internal static
	options (constant);

dcl  first_call bit (1) aligned static initial ("1"b);

dcl  1 static_backup_control aligned static,		/* control structure for backup_dump_ */
       2 header like backup_control.header,		/* ... global data */
       2 object like backup_control.requests;		/* ... the actual object to be dumped */

dcl  accessfile_bc fixed bin (24);
dcl  accessfile_ename char (32) static;
dcl  accessfile_lth fixed bin (21);
dcl  accessfile_path char (168) static;
dcl  accessfile_ptr pointer;
dcl  afs_ptr pointer;

dcl  abort_message character (100);
dcl  code_message character (100) aligned;
dcl  errfile_ename character (32) static;
dcl  errfile_pathname character (168) static;
dcl  mail_subject character (1024) varying;
dcl  process_dname character (168) static;		/* name of process directory which holds files for */
						/* access errors and hierarchy dump errors */
dcl  shortinfo character (8) aligned;

dcl  abort_request_label label static;			/* used by driver's any_other handler */
dcl  condition_name character (32) static;		/* condition causing request to abort */

dcl  error_table_$fatal_error fixed binary (35) external;
dcl  error_table_$moderr fixed binary (35) external;
dcl  error_table_$no_s_permission fixed binary (35) external;
dcl  error_table_$unimplemented_version fixed binary (35) external;
dcl  error_table_$user_not_found fixed binary (35) external;

dcl  imft_et_$reply_pending fixed binary (35) external;
dcl  imft_et_$timeout fixed binary (35) external;

dcl  backup_dump_ entry (pointer, fixed binary (35));
dcl  convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned);
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  delete_$path entry (char (*), char (*), bit (36), char (*), fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_group_id_ entry () returns (character (32));
dcl  get_pdir_ entry () returns (character (168));
dcl  get_ring_ entry () returns (fixed binary (3));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$quota_read
	entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18),
	fixed bin (35));
dcl  hcs_$initiate_count
	entry (character (*), character (*), character (*), fixed binary (24), fixed binary (2), pointer,
	fixed binary (35));
dcl  hcs_$make_seg entry (character (*), character (*), character (*), fixed binary (5), pointer, fixed binary (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$status_minf
	entry (character (*), character (*), fixed binary (1), fixed binary (2), fixed binary (24), fixed binary (35));
dcl  hcs_$set_bc entry (character (*), character (*), fixed binary (24), fixed binary (35));
dcl  hcs_$terminate_noname entry (pointer, fixed binary (35));
dcl  hcs_$truncate_file entry (character (*), character (*), fixed binary (19), fixed binary (35));
dcl  imft_convert_status_code_$decode entry (fixed binary (35)) returns (fixed binary (35));
dcl  imft_convert_status_code_$encode entry (fixed binary (35)) returns (fixed binary (35));
dcl  imft_mail_interface_$deliver_message
	entry (character (*), character (*), fixed binary, character (*), character (*), bit (72) aligned,
	fixed binary (35));
dcl  imft_util_$check_object_acl entry (ptr, fixed bin (35));
dcl  imft_util_$check_subtree_acl entry (ptr, fixed bin (35));
dcl  ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1));
dcl  ioa_$rsnnl entry () options (variable);
dcl  iodd_msg_ entry () options (variable);
dcl  ios_$attach entry (character (*), character (*), character (*), character (*), 1 aligned like ios_status);
dcl  ios_$detach entry (character (*), character (*), character (*), 1 aligned like ios_status);
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  term_$refname entry (character (*), fixed binary (35));
dcl  unique_chars_ entry (bit (*)) returns (character (15));

dcl  (cleanup, daemon_again, daemon_again_slave, daemon_cancel, daemon_defer, daemon_kill, daemon_save, imft_debug_,
     imft_remote_logout_, imft_resynchronize_driver_, imft_write_abort_, record_quota_overflow) condition;

dcl  (addr, clock, convert, currentsize, divide, fixed, float, hbound, ltrim, length, max, null, rtrim, string, substr,
     unspec) builtin;
%page;
%include access_mode_values;
%page;
%include acl_structures;
%page;
%include backup_control;
%page;
%include delete_options;
%page;
%include driver_status;
%page;
%include fs_star_;
%page;
%include "_imft_check_acl";
%page;
%include "_imft_cri";
%page;
%include "_imft_driver_info";
%page;
%include "_imft_ft_request";
%page;
%include "_imft_ft_commands";
%page;
%include "_imft_std_commands";
%page;
%include iod_tables_hdr;
%page;
%include iodd_msg_constants;
%page;
%include iodd_static;
%page;
%include mlsys_deliver_info;
%page;
%include mseg_message_info;
%page;
%include queue_msg_hdr;
%page;
%include request_descriptor;
%page;
%include status_structures;
%page;
%include star_structures;

     end imft_transmit_object_;




		    imft_tty_.pl1                   11/14/88  1517.9rew 11/14/88  1510.8      211455



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

/*
   This I/O module is for data transfer between IMFT and a communications channel being managed by tty_.
   It converts between IMFT logical records and stream data in 8-bit characters.
*/

/* Written January 1983 by Robert Coren */
/* Modified:  June 1983 by Robert Coren to requote attach options when building attach description */


/****^  HISTORY COMMENTS:
  1) change(87-11-15,Oke), approve(88-08-01,MCR7948), audit(88-10-11,Farley),
     install(88-10-14,MR12.2-1165):
     Add support for in_dial/out_dial drivers by adding
     imft_tty_(get_line put_chars) entries.  Also add debug code.
  2) change(88-11-10,Beattie), approve(88-08-01,PBF7948),
     audit(88-11-14,Farley), install(88-11-14,MR12.2-1214):
     Changed version check to be independent of debug_output to catch
     unexpected IO traffic from causing trouble later on.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,^ifthendo */

imft_tty_:
     procedure;

	return;					/* not an entry point */

/* attach a switch for communication between imft and tty_ */

imft_tty_attach:
     entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code);

	iocb_ptr = P_iocb_ptr;
	loud_sw = P_loud_sw;
	code = 0;

	iad_ptr = null ();				/* avoid freeing garbage if I/O switch already attached */

	if iocb_ptr -> iocb.attach_descrip_ptr ^= null ()
	then do;
	     P_code = error_table_$not_detached;
	     if loud_sw
	     then call com_err_ (P_code, IMFT_TTY_, "For switch ^a.", iocb_ptr -> iocb.name);
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup) call cleanup_attachment (ignore_code);

	allocate iad in (system_area) set (iad_ptr);
	iad.terminal_iocb_ptr = null ();		/* keeps cleanup handler happy */
	iad.record_buffer_ptr = null ();

	iad.attach_description = "";
	iad.open_description = "";


	do arg_index = lbound (P_attach_options, 1) to hbound (P_attach_options, 1);
	     iad.attach_description = iad.attach_description || " " || requote_string_ ((P_attach_options (arg_index)));
	end;

	terminal_switch_name = "tty_" || "." || rtrim (iocb_ptr -> iocb.name);
	terminal_attach_desc = "tty_" || iad.attach_description;
						/* note that iad.attach_description already has leading space */

	call iox_$attach_ioname (terminal_switch_name, iad.terminal_iocb_ptr, terminal_attach_desc, code);
	if code ^= 0
	then call abort_attachment (code, "Unable to attach channel via: ^a", terminal_attach_desc);

	size_of_unpacked_header = divide (36 * size (imft_logical_record_header) + 7, 8, 17, 0);

	max_record_length = 4 * size (imft_logical_record_header) + IMFT_MAX_RECORD_LENGTH;
						/* this is maximum length of real record */
	max_record_length = divide (9 * max_record_length + 7, 8, 21, 0);
						/* this is unpacked maximum length as we might have to read or write it */

	allocate record_buffer in (system_area) set (iad.record_buffer_ptr);
						/* Mask and complete construction of the IOCB */

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (MASK_OFF, ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = addr (iad.attach_description);
	iocb_ptr -> iocb.attach_data_ptr = iad_ptr;
	iocb_ptr -> iocb.open = imft_tty_open;
	iocb_ptr -> iocb.detach_iocb = imft_tty_detach;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

RETURN_FROM_ATTACH:
	P_code = code;
	return;
%page;
/* Open an I/O switch for file transfer */

imft_tty_open:
     entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null ()
	then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	open_mode = P_open_mode;
	input_allowed, output_allowed = "0"b;		/* we don't know about either yet */

	if open_mode = Sequential_input
	then do;
	     tty_open_mode = Stream_input;
	     input_allowed = "1"b;
	end;

	else if open_mode = Sequential_output
	then do;
	     tty_open_mode = Stream_output;
	     output_allowed = "1"b;
	end;

	else if open_mode = Sequential_input_output
	then do;
	     tty_open_mode = Stream_input_output;
	     input_allowed, output_allowed = "1"b;
	end;

	else do;
	     P_code = error_table_$bad_mode;
	     return;
	end;

	call iox_$open (iad.terminal_iocb_ptr, tty_open_mode, "0"b, P_code);
	if P_code ^= 0
	then return;

	call iox_$modes (iad.terminal_iocb_ptr, "force,init,rawi,rawo,^blk_xfer,^breakall,^iflow,^oflow,^no_outp,8bit",
	     old_modes, ignore_code);			/* This allows us to use 8-bit characters */

	iad.open_description = rtrim (iox_modes (open_mode));

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (MASK_OFF, ips_mask);

	iocb_ptr -> iocb.get_line = imft_tty_get_line;
	iocb_ptr -> iocb.put_chars = imft_tty_put_chars;

	if input_allowed
	then iocb_ptr -> iocb.read_record = imft_tty_read_record;

	if output_allowed
	then iocb_ptr -> iocb.write_record = imft_tty_write_record;

	iocb_ptr -> iocb.control = imft_tty_control;
	iocb_ptr -> iocb.modes = imft_tty_modes;

	iocb_ptr -> iocb.close = imft_tty_close;
	iocb_ptr -> iocb.detach_iocb = imft_tty_detach;

	iocb_ptr -> iocb.open_descrip_ptr = addr (iad.open_description);
						/* it's now open */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = 0;
	return;
%page;
/* Close an I/O switch used for file transfer */

imft_tty_close:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	code = 0;

	if iocb_ptr -> iocb.open_descrip_ptr = null ()
	then do;
	     P_code = error_table_$not_open;
	     return;
	end;

	call iox_$close (iad.terminal_iocb_ptr, code);
	if (code = error_table_$not_open) | (code = error_table_$not_attached)
	then code = 0;

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (MASK_OFF, ips_mask);

	iocb_ptr -> iocb.open_descrip_ptr = null ();

	iocb_ptr -> iocb.open = imft_tty_open;
	iocb_ptr -> iocb.detach_iocb = imft_tty_detach;

	iocb_ptr -> iocb.control, iocb_ptr -> iocb.modes, iocb_ptr -> iocb.read_record, iocb_ptr -> iocb.write_record =
	     iox_$err_no_operation;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = code;

	return;
%page;
/* Detach an I/O switch from file transfer */

imft_tty_detach:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr;
	code = 0;

	if iocb_ptr -> iocb.attach_descrip_ptr = null ()
	then do;
	     P_code = error_table_$not_attached;
	     return;
	end;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null ()
	then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	call cleanup_attachment (code);

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (MASK_OFF, ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = null ();	/* it's detached */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = code;				/* in case trouble freeing the channel */
	return;
%page;
/* Perform control operations on an I/O switch attached for file transfer */

imft_tty_control:
     entry (P_iocb_ptr, P_order, P_info_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	call iox_$control (iad.terminal_iocb_ptr, P_order, P_info_ptr, P_code);
						/* just pass all orders on */
	return;
%skip (10);
/* Change modes: no modes are supported */

imft_tty_modes:
     entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	P_old_modes = "";				/* no modes are reflected to caller */

	if P_new_modes = ""
	then P_code = 0;
	else P_code = error_table_$bad_mode;

	return;
%page;
/*
   Get a character line from the basic connection.  Used for protocol setup
   in the out_dial connection.
*/

imft_tty_get_line:
     entry (P_iocb_ptr, P_buffer_ptr, P_buffer_max_length, P_data_lth, P_code);

	iocb_ptr = P_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	call iox_$get_line (iad.terminal_iocb_ptr, P_buffer_ptr, P_buffer_max_length, P_data_lth, P_code);
	if debug_output
	then call debug_out ("get_line", P_buffer_ptr, (P_data_lth));
	return;
%skip (10);
/*
   Put a character string to the basic connection.  Used for potocol setup
   in the out_dial connection, and a prompt on the in_dial connection.
*/

imft_tty_put_chars:
     entry (P_iocb_ptr, P_buffer_ptr, P_data_lth, P_code);

	iocb_ptr = P_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	call iox_$put_chars (iad.terminal_iocb_ptr, P_buffer_ptr, P_data_lth, P_code);
	if debug_output
	then call debug_out ("put_chars", P_buffer_ptr, (P_data_lth));
	return;
%page;
/* given an IMFT logical record, write it in stream mode, unpacked if necessary */

imft_tty_write_record:
     entry (P_iocb_ptr, P_record_ptr, P_record_length, P_code);

	iocb_ptr = P_iocb_ptr;
	ilr_ptr = P_record_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	buffer_ptr = iad.record_buffer_ptr;

/* header first, which is always binary, and so needs to be unpacked */

	call unpack (ilr_ptr, buffer_ptr, 4 * size (imft_logical_record_header), unpacked_bytes);

	if imft_logical_record.version ^= IMFT_LOGICAL_RECORD_VERSION_1
	then do;
	     if debug_output
	     then do;
		call ioa_ ("Version Sent: ^a^/Version Desired: ^a", imft_logical_record.version,
		     IMFT_LOGICAL_RECORD_VERSION_1);
		call debug_out ("write_record (header)", ilr_ptr, 4 * size (imft_logical_record_header));
		call debug_out ("unpacked header", buffer_ptr, (unpacked_bytes));
	     end;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	call iox_$put_chars (iad.terminal_iocb_ptr, buffer_ptr, unpacked_bytes, P_code);
	if debug_output
	then call debug_out ("write_record (header)", buffer_ptr, (unpacked_bytes));
	if P_code ^= 0
	then return;

	if imft_logical_record.length > 0
	then do;
	     if imft_logical_record.binary
	     then do;				/* have to unpack it */
		call unpack (addr (imft_logical_record.contents), buffer_ptr, imft_logical_record.length,
		     unpacked_bytes);
		call iox_$put_chars (iad.terminal_iocb_ptr, buffer_ptr, unpacked_bytes, P_code);
		if debug_output
		then call debug_out ("write_record (binary body)", buffer_ptr, (unpacked_bytes));
	     end;

	     else do;
		call iox_$put_chars (iad.terminal_iocb_ptr, addr (imft_logical_record.contents),
		     imft_logical_record.length, P_code);
		if debug_output
		then call debug_out ("write_record (char body)", addr (imft_logical_record.contents),
			(imft_logical_record.length));
	     end;
	end;

	return;
%page;
/* read characters from the switch and put them into a logical record to return to the caller */

imft_tty_read_record:
     entry (P_iocb_ptr, P_record_ptr, P_max_length, P_record_length, P_code);

	iocb_ptr = P_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	ilr_ptr = P_record_ptr;
	buffer_ptr = iad.record_buffer_ptr;

	if P_max_length < 4 * size (imft_logical_record_header)
	then do;					/* can't even hold header, this is absurd */
	     code = error_table_$smallarg;		/* long_record would give the wrong idea */
	     return;
	end;

/* read the header first -- it always has to be packed */

	chars_read = 0;
	do while (chars_read < size_of_unpacked_header);
	     call iox_$get_chars (iad.terminal_iocb_ptr, addcharno (buffer_ptr, chars_read),
		size_of_unpacked_header - chars_read, chars_read_this_time, P_code);
	     if P_code ^= 0
	     then return;

	     chars_read = chars_read + chars_read_this_time;
	end;

	if debug_output
	then call debug_out ("read_record (header)", buffer_ptr, (chars_read));
	call pack (buffer_ptr, ilr_ptr, (size_of_unpacked_header), size_of_packed_header);

	if imft_logical_record.version ^= IMFT_LOGICAL_RECORD_VERSION_1
	then do;
	     if debug_output
	     then do;
		call ioa_ ("Version Received: ^a^/Version Desired: ^a", imft_logical_record.version,
		     IMFT_LOGICAL_RECORD_VERSION_1);
		call debug_out ("read_record (header)", buffer_ptr, (chars_read));
		call debug_out ("packed header", ilr_ptr, (chars_read / 8) * 9);
	     end;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if imft_logical_record.length = 0
	then do;					/* record consists of header only */
	     P_record_length = 4 * size (imft_logical_record_header);
	     return;
	end;

	room_left = P_max_length - size_of_packed_header;
	chars_read = 0;

	if imft_logical_record.binary
	then do;					/* we'll have to pack the rest, too */
	     raw_chars_read = 0;
	     chars_to_read = divide (9 * imft_logical_record.length + 7, 8, 21, 0);
	     max_unpacked_chars = divide (9 * room_left + 7, 8, 21, 0);
	     actual_limit = min (chars_to_read, max_unpacked_chars);

	     do while (raw_chars_read < actual_limit);
		call iox_$get_chars (iad.terminal_iocb_ptr, addcharno (buffer_ptr, raw_chars_read),
		     actual_limit - raw_chars_read, chars_read_this_time, P_code);
		if P_code ^= 0
		then return;

		if raw_chars_read + chars_read_this_time > max_unpacked_chars
		then do;
		     chars_read_this_time = max_unpacked_chars - raw_chars_read;
		     P_code = error_table_$long_record;
		end;

		raw_chars_read = raw_chars_read + chars_read_this_time;
	     end;
	     if debug_output
	     then call debug_out ("read_record (binary body)", buffer_ptr, (raw_chars_read));
	     call pack (buffer_ptr, addr (imft_logical_record.contents), raw_chars_read, chars_read);
	end;

	else do;					/* not binary data, doesn't need packing */
	     chars_to_read = imft_logical_record.length;

	     do while (chars_read < imft_logical_record.length & room_left > 0);
		n_chars = min (chars_to_read, room_left);
		call iox_$get_chars (iad.terminal_iocb_ptr,
		     addcharno (addr (imft_logical_record.contents), chars_read), n_chars, chars_read_this_time,
		     P_code);
		if P_code ^= 0
		then return;

		chars_read = chars_read + chars_read_this_time;
		chars_to_read = chars_to_read - chars_read_this_time;
		room_left = room_left - chars_read_this_time;
	     end;

	     if chars_read < imft_logical_record.length
	     then P_code = error_table_$long_record;
	end;

	if debug_output
	then call debug_out ("read_record (char body)", addr (imft_logical_record.contents), (chars_read));
	P_record_length = 4 * size (imft_logical_record_header) + chars_read;
	return;
%page;
/* pair of subroutines for converting between 8 bits/byte and 9 bits/byte */

pack_unpack:
     procedure;

	return;					/* not to be called */

dcl  packed_byte_ptr pointer parameter;
dcl  unpacked_byte_ptr pointer parameter;
dcl  P_input_length fixed bin (21) parameter;
dcl  P_output_length fixed bin (21) parameter;

dcl  unpacked_length fixed bin;
dcl  packed_bytes (unpacked_length) bit (8) unaligned based (packed_byte_ptr);
dcl  unpacked_bytes (unpacked_length) bit (9) unaligned based (unpacked_byte_ptr);

pack:
     entry (unpacked_byte_ptr, packed_byte_ptr, P_input_length, P_output_length);

/* input has high-order bit of every 9 off, + 8 data bits; pack it into binary */

	unpacked_length = P_input_length;
	P_output_length = divide (8 * unpacked_length, 9, 21, 0);
	packed_bytes = substr (unpacked_bytes, 2);	/* simple as that! */
	return;


unpack:
     entry (packed_byte_ptr, unpacked_byte_ptr, P_input_length, P_output_length);

/* input is binary; unpack it so that high-order bit of every 9 is 0 */

	P_output_length, unpacked_length = divide (9 * P_input_length + 7, 8, 21, 0);
	string (unpacked_bytes) = ""b;
	substr (unpacked_bytes, 2) = packed_bytes;	/* it works in this direction, too */
	return;

     end pack_unpack;
%page;
/* Cleanup whatever portion of an attachment exists */

cleanup_attachment:
     procedure (P_code);

dcl  P_code fixed binary (35) parameter;		/* a parameter to allow callers to ignore it */

	P_code = 0;

	if iad_ptr ^= null ()
	then do;					/* there is an I/O switch */

	     if iad.terminal_iocb_ptr ^= null ()
	     then do;
		call iox_$close (iad.terminal_iocb_ptr, ignore_code);
		call iox_$detach_iocb (iad.terminal_iocb_ptr, P_code);
		call iox_$destroy_iocb (iad.terminal_iocb_ptr, ignore_code);
		iad.terminal_iocb_ptr = null ();
	     end;

	     if iad.record_buffer_ptr ^= null ()
	     then free iad.record_buffer_ptr -> record_buffer in (system_area);

	     free iad in (system_area);
	     iad_ptr = null ();

	end;

	return;

     end cleanup_attachment;
%page;
/* Wrapper to protect against errors while IPS interrupts are masked */

any_other_handler:
     procedure () options (non_quick);

	if ips_mask
	then call hcs_$reset_ips_mask (ips_mask, ips_mask);
	ips_mask = ""b;

	call continue_to_signal_ (ignore_code);		/* not interested, */

	return;

     end any_other_handler;



/* Abort a call to the attach entry:  print an error message if requested */

abort_attachment:
     procedure () options (variable, non_quick);

dcl  the_code fixed binary (35) based (the_code_ptr);
dcl  the_code_ptr pointer;

dcl  caller_message character (256);

	call cu_$arg_ptr (1, the_code_ptr, ignore_fb21, ignore_code);

	if loud_sw
	then do;					/* an error message is requested */
	     call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, ignore_fb21, "1"b, "0"b);
	     call com_err_ (the_code, IMFT_TTY_, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message);
	end;

	call cleanup_attachment (ignore_code);		/* get rid of anything that was accomplished */

	if the_code = 0
	then code = error_table_$action_not_performed;
	else code = the_code;			/* save the error code */

	go to RETURN_FROM_ATTACH;

     end abort_attachment;
%page;

debug_out:
     proc (me, buf_ptr, buf_len);

dcl  me char (*);
dcl  buf_ptr ptr;
dcl  buf_len fixed bin;
dcl  str char (buf_len) unaligned based (buf_ptr);
dcl  stb bit (buf_len * 9) unaligned based (buf_ptr);

	call ioa_ ("^a(^i) ^p: ""^a""", me, buf_len, buf_ptr, str);
	call ioa_ ("^vb", buf_len * 9, stb);

     end debug_out;
%skip (4);
dcl  debug_output bit (1) static initial ("0"b);

debug_list:
     entry;

	debug_output = "1"b;
	return;
%page;

dcl  P_buffer_max_length fixed bin (21) parameter;	/* max length of IO */
dcl  P_buffer_ptr pointer parameter;			/* -> buffer */
dcl  P_data_lth fixed bin (21) parameter;		/* length of IO */
dcl  P_iocb_ptr pointer parameter;			/* -> IOCB */
dcl  P_attach_options (*) character (*) varying parameter;	/* attach: attachment arguments */
dcl  P_loud_sw bit (1) parameter;			/* attach: ON => attachment errors should call com_err_ */

dcl  P_open_mode fixed binary parameter;		/* open: opening mode */
dcl  P_open_sw bit (1) parameter;			/* open: obsolete parameter */

dcl  P_record_ptr pointer parameter;			/* (read write)_record: -> record */
dcl  P_record_length fixed bin (21) parameter;		/* read_record: actual length of record read */
						/* write_record: length of record to be written */

dcl  P_max_length fixed bin (21) parameter;		/* read_record: length of caller-supplied buffer */
dcl  P_code fixed bin (35);				/* status code */


dcl  P_order character (*) parameter;			/* control: name of control order to be performed */
dcl  P_info_ptr pointer parameter;			/* control: -> additional information required to execute the
						   control order */

dcl  P_new_modes character (*) parameter;		/* modes: new modes to be set */
dcl  P_old_modes character (*) parameter;		/* modes: set to modes in effect before change */

/* Local copies of parameters */

dcl  iocb_ptr pointer;
dcl  code fixed binary (35);
dcl  ignore_code fixed binary (35);
dcl  ignore_fb21 fixed binary (21);
dcl  loud_sw bit (1) aligned;
dcl  open_mode fixed binary;

/* other declarations */

/* AUTOMATIC */

dcl  system_area area aligned based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  arg_index fixed binary;				/* # of attach option being processed */

dcl  terminal_attach_desc character (512);
dcl  terminal_switch_name character (32);
dcl  iad_ptr pointer;
dcl  max_record_length fixed bin (21);
dcl  tty_open_mode fixed bin;
dcl  input_allowed bit (1);
dcl  output_allowed bit (1);
dcl  old_modes char (256);

dcl  unpacked_bytes fixed bin (21);
dcl  chars_read fixed bin (21);
dcl  chars_read_this_time fixed bin (21);
dcl  size_of_packed_header fixed bin (21);
dcl  room_left fixed bin (21);
dcl  raw_chars_read fixed bin (21);
dcl  chars_to_read fixed bin (21);
dcl  max_unpacked_chars fixed bin (21);
dcl  n_chars fixed bin (21);
dcl  buffer_ptr pointer;
dcl  actual_limit fixed bin;
dcl  ips_mask bit (36);

/* BASED */

dcl  record_buffer char (max_record_length) based;

dcl  1 iad based (iad_ptr) aligned,
       2 attach_description char (1024) varying,
       2 open_description char (24) varying,
       2 terminal_iocb_ptr pointer,
       2 record_buffer_ptr pointer;

/* ENTRIES */

dcl  com_err_ entry () options (variable);
dcl  continue_to_signal_ entry (fixed binary (35));
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$reset_ips_mask entry (bit (36), bit (36));
dcl  hcs_$set_ips_mask entry (bit (36), bit (36));
dcl  ioa_ entry () options (variable);
dcl  ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1));
dcl  iox_$attach_ioname entry (character (*), pointer, character (*), fixed binary (35));
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  iox_$close entry (pointer, fixed binary (35));
dcl  iox_$destroy_iocb entry (pointer, fixed binary (35));
dcl  iox_$detach_iocb entry (pointer, fixed binary (35));
dcl  iox_$err_no_operation entry () options (variable);
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35));
dcl  iox_$propagate entry (pointer);
dcl  iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  requote_string_ entry (char (*)) returns (char (*));

/* EXTERNAL STATIC */

dcl  (
     error_table_$action_not_performed,
     error_table_$bad_mode,
     error_table_$long_record,
     error_table_$not_attached,
     error_table_$not_closed,
     error_table_$not_detached,
     error_table_$not_open,
     error_table_$smallarg,
     error_table_$unimplemented_version
     ) fixed bin (35) external static;

/* INTERNAL STATIC */

dcl  IMFT_TTY_ character (32) static options (constant) initial ("imft_tty_");
dcl  MASK_OFF bit (36) init ((36)"0"b) internal static options (constant);
dcl  size_of_unpacked_header fixed bin internal static;

/* BUILTINS & CONDITIONS */

dcl  (addcharno, addr, divide, hbound, lbound, min, null, rtrim, size, string, substr) builtin;

dcl  (any_other, cleanup) condition;
%page;
%include iocb;
%page;
%include iox_modes;
%page;
%include imft_logical_record;
     end imft_tty_;




		    imft_util_.pl1                  10/27/88  1310.7rew 10/27/88  1309.4      174465



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

/* format: style1,^inddcls,insnl,delnl,indend,indnoniterend,indbeginend,indthenbeginend,tree,^case */

/****^  HISTORY COMMENTS:
  1) change(88-08-11,Beattie), approve(88-08-01,MCR7948),
     audit(88-10-11,Farley), install(88-10-14,MR12.2-1165):
     Created to support IMFT access checking.
  2) change(88-10-26,Beattie), approve(88-08-01,PBF7948),
     audit(88-10-27,Farley), install(88-10-27,MR12.2-1195):
     Changed check_object_acl entry to be able to chase nonstar links.
                                                   END HISTORY COMMENTS */

imft_util_:
     procedure;

	return;					/* not an entry point */

check_object_acl:
     entry (p_check_acl_ptr, p_code);

	ME = "imft_util_$check_object_acl";
	checking_subtree = "0"b;

	afs_ptr = null ();
	star_optionsP = null ();
	on cleanup call CLEANUP ();

	call init_check_acl ();

	star_paths.value (1) = pathname_ ((imft_check_acl.dirname), (imft_check_acl.ename));
	star_options.entry_type.links = ENTRY_RETURN | ENTRY_CHASE_NONSTAR_LINKS;
	star_options.entry_type.dirs = ENTRY_RETURN | ENTRY_DONT_LIST_SUBENTRIES;
	go to COMMON;

check_subtree_acl:
     entry (p_check_acl_ptr, p_code);

	ME = "imft_util_$check_subtree_acl";
	checking_subtree = "1"b;

	afs_ptr = null ();
	star_optionsP = null ();
	on cleanup call CLEANUP ();

	call init_check_acl ();

/**** Set up file to collect error messages */

	call expand_pathname_ ((imft_check_acl.accessfile_pathname), accessfile_dname, accessfile_ename, ignore_code);
	call hcs_$truncate_file (accessfile_dname, accessfile_ename, 0, ignore_code);
	call hcs_$set_bc (accessfile_dname, accessfile_ename, 0, ignore_code);
	call ioa_$rsnnl ("vfile_ ^a -extend -ssf", attach_desc, message_len, accessfile_pathname);
	call iox_$find_iocb ("accessfile_switch", afs_ptr, code);
	if code ^= 0
	then do;
		call convert_status_code_ (code, shortinfo, longinfo);
		call ioa_$rsnnl ("Tried to find an IOCB for accessfile switch.^/(^a)",
		     imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, longinfo);
		p_code = code;
		go to BAIL_OUT;
		end;

	call iox_$attach_ptr (afs_ptr, attach_desc, (null ()), code);
	if code ^= 0
	then do;
		call convert_status_code_ (code, shortinfo, longinfo);
		call ioa_$rsnnl ("Tried to attach vfile_ to ^a^/(^a)",
		     imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, accessfile_pathname,
		     longinfo);
		p_code = code;
		go to BAIL_OUT;
		end;

	call iox_$open (afs_ptr, Stream_output, "0"b, code);
	if code ^= 0
	then do;
		call convert_status_code_ (code, shortinfo, longinfo);
		call ioa_$rsnnl ("Tried to open accessfile_switch to ^a^/(^a)",
		     imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, accessfile_pathname,
		     longinfo);
		p_code = code;
		go to BAIL_OUT;
		end;

	star_paths.value (1) = pathname_ ((imft_check_acl.dirname), rtrim (imft_check_acl.ename) || ">**");
	star_options.entry_type.links = ENTRY_DONT_RETURN;
	star_options.entry_type.dirs = ENTRY_RETURN | ENTRY_LIST_SUBENTRIES;

COMMON:
	call fs_star_$select (star_optionsP, star_dataP, code);
	if code ^= 0
	then do;
		imft_check_acl.allow_transfer = "0"b;
		call convert_status_code_ (code, shortinfo, longinfo);
		call ioa_$rsnnl ("^a: Error while checking access to objects in subtree.^/(^a)",
		     imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, ME, longinfo);
		p_code = code;
		go to BAIL_OUT;
		end;

BAIL_OUT:
	call CLEANUP ();

RETURN:
	return;
%page;
/****
     This is called by fs_star_ for each object it was directed to find.
*/

check_fs_entry:
     proc (P_star_data_ptr, Pdir, Pent, Pcomp, Paction);

dcl     P_star_data_ptr	 pointer;
dcl     Pdir		 char (*);
dcl     Pent		 (*) char (32) parm;
dcl     Pcomp		 char (*) parm;
dcl     Paction		 fixed bin parm;

dcl     access_error	 bit (1);
dcl     code		 fixed bin (35);
dcl     local_dirname	 char (168);
dcl     local_ename		 char (32);
dcl     local_pathname	 char (168);
dcl     my_access_ok	 bit (1);
dcl     user_access_ok	 bit (1);

	star_dataP = P_star_data_ptr;
	local_dirname = Pdir;
	local_ename = Pent (1);
	local_pathname = pathname_ (local_dirname, local_ename);
	Paction = HANDLER_OK;			/* unless a problem is found */

	general_acl.status_code = 0;

	if ^checking_subtree			/* let caller know what type object this is */
	then imft_check_acl.type = star_data.type;	/* unless checking a subtree */
%page;
/**** Check ring brackets. */

	if star_data.type = ENTRY_TYPE_DIRECTORY | star_data.type = ENTRY_TYPE_DM_FILE | star_data.type = ENTRY_TYPE_MSF
	then do;
		call hcs_$get_dir_ring_brackets (local_dirname, local_ename, dir_ring_brackets, code);
		if code = 0
		then do;
			if ^checking_subtree
			then imft_check_acl.object_ring = dir_ring_brackets (1);

			if imft_check_acl.effective_ring > dir_ring_brackets (1)
			then code = error_table_$lower_ring;
			end;
		end;				/* if star_data.type in set of directories */

	else do;
		call hcs_$get_ring_brackets (local_dirname, local_ename, seg_ring_brackets, code);
		if code = 0
		then do;
			if ^checking_subtree
			then imft_check_acl.object_ring = seg_ring_brackets (1);

			if imft_check_acl.effective_ring > seg_ring_brackets (1)
			then code = error_table_$lower_ring;
			end;
		end;				/* if star_data.type not in set of directories */

	if code ^= 0
	then do;
		general_acl (imft_check_acl.bad_acl_idx).status_code = code;
		call set_error_message ();
		return;
		end;
%page;
/**** Check ACL of object. */

	if star_data.type = ENTRY_TYPE_DIRECTORY
	then do;
		access_str = DIR_ACCESS_MODE_NAMES (bin (imft_check_acl.dir_access));
		test_access = imft_check_acl.dir_access;
		end;
	else do;
		access_str = SEG_ACCESS_MODE_NAMES (bin (imft_check_acl.seg_access));
		test_access = imft_check_acl.seg_access;
		end;

	call fs_util_$list_acl (local_dirname, local_ename, GENERAL_ACL_VERSION_1, null (), imft_check_acl.gen_acl_ptr,
	     code);
	if code ^= 0
	then do;
		imft_check_acl.error_code = code;
		call set_error_message ();
		return;
		end;

	access_error = "0"b;
	do acl_idx = 1 to hbound (general_acl.mode, 1);
	     code = 0;
	     if general_acl (acl_idx).status_code ^= 0	/* Person.Project is not present */
	     then code = general_acl (acl_idx).status_code;

	     else if (general_acl (acl_idx).mode & test_access) ^= test_access
						/* explicitly denied access */
		then general_acl (acl_idx).status_code, code = error_table_$moderr;
	     imft_check_acl.bad_acl_idx = acl_idx;	/* record current pass, it may be last one */
	     if code ^= 0
	     then call set_error_message ();
	     end;					/* loop on acl_idx */

	if access_error
	then return;
%page;
/**** Check AIM of object. */

	if imft_check_acl.check_aim
	then do;

		call hcs_$get_access_class (local_dirname, local_ename, local_obj_access_class, code);
		if code ^= 0
		then do;
			call convert_status_code_ (code, shortinfo, longinfo);
			call ioa_$rsnnl (
			     "^[^/^]Access error: ^a^/Attempting to determine access class of^[^/^2x^a^; object.^]",
			     imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len,
			     checking_subtree, longinfo, checking_subtree, local_pathname);
			call process_error ();
			end;

		my_access_ok = aim_check_$greater_or_equal (imft_check_acl.sys_auth_ceiling, local_obj_access_class);
		if my_access_ok
		then my_access_ok =
			aim_check_$greater_or_equal (local_obj_access_class, imft_check_acl.sys_auth_floor);
		if ^my_access_ok
		then do;				/* access class exceeds maximum allowed for transfer */
			object_access_class_text, max_access_class_text = "";
			call convert_authorization_$to_string_short (local_obj_access_class,
			     object_access_class_text, ignore_code);
			call convert_authorization_$to_string_short (imft_check_acl.sys_auth_ceiling,
			     max_access_class_text, ignore_code);
			call convert_authorization_$to_string_short (imft_check_acl.sys_auth_floor,
			     min_access_class_text, ignore_code);
			imft_check_acl.bad_acl_idx = DRIVER_ACL_IDX;
			general_acl (DRIVER_ACL_IDX).status_code, code = error_table_$ai_restricted;
			call convert_status_code_ (code, shortinfo, longinfo);
			call ioa_$rsnnl (
			     "^[^/^]Access error: ^a^/^2xAccess class of object (^[^a^;^ssystem_low^]) is not within the range permitted for transfer to ^a (^[^a^;^ssystem_low^]:^[^a^;^ssystem_low^])^[^/^2x^a^;^s.^]",
			     imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len,
			     checking_subtree, longinfo, (object_access_class_text ^= ""), object_access_class_text,
			     imft_check_acl.foreign_sys_name, (min_access_class_text ^= ""), min_access_class_text,
			     (max_access_class_text ^= ""), max_access_class_text, checking_subtree, local_pathname)
			     ;
			call process_error ();
			end;
%page;
/**** Check AIM of user with object. */

		user_access_ok = aim_check_$greater_or_equal (imft_check_acl.user_auth, local_obj_access_class);
		if ^user_access_ok
		then do;				/* AIM strikes again */
			imft_check_acl.bad_acl_idx = USER_ACL_IDX;
			general_acl (USER_ACL_IDX).status_code, code = error_table_$ai_restricted;
			call convert_status_code_ (code, shortinfo, longinfo);
			user_authorization_text = "";
			call convert_authorization_$to_string_short (imft_check_acl.user_auth,
			     user_authorization_text, ignore_code);
			call ioa_$rsnnl (
			     "^[^/^]Access error: ^a^/^2x^a (at authorization ^[^a^;^ssystem_low^]) can not ^[examine^;read^]^[^/^2x^a^;^s object.^]",
			     imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len,
			     checking_subtree, longinfo, general_acl (USER_ACL_IDX).access_name,
			     (user_authorization_text ^= ""), user_authorization_text,
			     (star_data.type = ENTRY_TYPE_DIRECTORY), checking_subtree, local_pathname);
			call process_error ();
			end;

		if access_error
		then return;
		end;				/* if imft_check_acl.check_aim */

	imft_check_acl.objects_to_transfer = "1"b;
	return;
%page;
/****
     This is called by fs_star_ to indicate that some error occured in
     accessing the indicated object.  Any call to this routine is considered
     an access failure and the IMFT request is not to be processed.
*/

analyze_fs_error:
     entry (P_star_data_ptr, Pdir, Pent, Pcomp, Pcode, Pmessage, Paction);

dcl     Pcode		 fixed bin (35) parameter;
dcl     Pmessage		 char (*) parameter;

dcl     local_path		 char (168);

	Paction = ERROR_REJECT;
	code = Pcode;
	call convert_status_code_ (code, shortinfo, longinfo);

	if Pent (1) = ""
	then local_path = Pdir;
	else local_path = pathname_ (Pdir, Pent (1));

	call ioa_$rsnnl ("^a: Error from fs_star_ ERROR handler while processing:^/^2x^a^/^2x^a^[^/^2x(^a)^]",
	     imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, ME, local_path, longinfo,
	     (Pmessage ^= ""), Pmessage);
	call process_error ();
	return;
%page;
/****
     Internal routine to set up an appropriate error message.
*/

set_error_message:
     proc;

	call convert_status_code_ (code, shortinfo, longinfo);
	bad_access_name = general_acl (imft_check_acl.bad_acl_idx).access_name;

	if substr (star_data.type, 1, 1) = "-"
	then object_type = substr (star_data.type, 2);
	else object_type = star_data.type;

	if code = error_table_$user_not_found
	then call ioa_$rsnnl (
		"^[^/^]Access error: ^a^/^2xAn explicit ACL entry for ^[Driver^;User^] (^a)^[^/^2xmust appear on ^a^; must appear on object.^]",
		imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, checking_subtree, longinfo,
		(imft_check_acl.bad_acl_idx = DRIVER_ACL_IDX), bad_access_name, checking_subtree, local_pathname);
	else if code = error_table_$moderr
	     then call ioa_$rsnnl (
		     "^[^/^]Access error: ^a^/^2xAccess mode ^a must be given in ACL entry for ^[Driver^;User^] (^a)^[^/^2xwhich appears on ^a^; which appears on object.^]",
		     imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, checking_subtree,
		     longinfo, access_str, (imft_check_acl.bad_acl_idx = DRIVER_ACL_IDX), bad_access_name,
		     checking_subtree, local_pathname);
	     else if code = error_table_$lower_ring
		then call ioa_$rsnnl (
			"^[^/^]Access error: ^a^/^2xThe ^a object cannot be transfered because ring brackets less than user execution ring.^[^/^2x^a^]",
			imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, checking_subtree,
			longinfo, object_type, checking_subtree, local_pathname);
		else call ioa_$rsnnl (
			"^[^/^]Access error: ^a^/^2xDetermining driver (^a) and user (^a)^[^/^2xaccess to: ^a^; access to object.^]",
			imft_check_acl (imft_check_acl.bad_acl_idx).error_message, checking_subtree, message_len,
			longinfo, general_acl (DRIVER_ACL_IDX).access_name, general_acl (USER_ACL_IDX).access_name,
			checking_subtree, local_pathname);

	call process_error ();

     end set_error_message;
%page;
/**** Internal routine to process error code and set up for return. */

process_error:
     proc;

dcl     buffer		 character (512);
dcl     iox_code		 fixed bin (35);

	Paction = HANDLER_DONT_EXPAND;
	access_error = "1"b;

	if checking_subtree
	then do;					/* collect errors to send as mail */
		buffer = imft_check_acl (imft_check_acl.bad_acl_idx).error_message;
		call iox_$put_chars (afs_ptr, addr (buffer), message_len, iox_code);
		if iox_code ^= 0
		then do;
			call ioa_$rsnnl ("^a: Tried to write to ^a",
			     imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, ME,
			     imft_check_acl.accessfile_pathname);
			p_code = iox_code;
			go to BAIL_OUT;
			end;
		end;				/* if checking_subtree */

	if code ^= 0
	then if code = error_table_$lower_ring
	     then imft_check_acl.found_inner_ring_object = "1"b;
	     else imft_check_acl.allow_transfer = "0"b;

     end process_error;

     end check_fs_entry;
%page;
init_check_acl:
     proc;
	imft_check_acl_ptr = p_check_acl_ptr;

	if imft_check_acl.version ^= IMFT_CHECK_ACL_VERSION_1
	then do;					/* cannot use this structure for error messages, etc */
						/* caller will have to special case */
		p_code = error_table_$unimplemented_version;
		go to RETURN;
		end;

	code, p_code = 0;				/* for now */

	call fs_star_$init (null (), ME, "", STAR_OPTIONS_VERSION_1, star_optionsP, code);
	if code ^= 0
	then do;
		imft_check_acl.allow_transfer = "0"b;
		call convert_status_code_ (code, shortinfo, longinfo);
		call ioa_$rsnnl ("^a: Error from fs_star_$init: ^a", imft_check_acl.error_message, message_len, ME,
		     longinfo);
		p_code = code;
		go to BAIL_OUT;
		end;

	star_paths.version = STAR_PATHS_VERSION_1;
	star_paths.count = 1;
	star_options.entry_type.segs = ENTRY_RETURN;
	star_options.entry_type.archives = ENTRY_RETURN;
	star_options.entry_type.msfs = ENTRY_RETURN;
	star_options.entry_type.msf_comps = ENTRY_DONT_RETURN;
	star_options.entry_type.dm_files = ENTRY_RETURN | ENTRY_INASE;
	star_options.entry_type.extended_entries = ENTRY_RETURN | ENTRY_INASE;
	star_options.entry_type.arch_comps = ENTRY_DONT_RETURN;
	star_options.extended_entry_typesP = null ();
	star_options.match_namesP = null ();
	star_options.exclude_namesP = null ();
	star_options.sorting = SORT_OFF;
	star_options.handler = check_fs_entry;
	star_options.error = analyze_fs_error;
	star_options.handler_dataP = null ();
	imft_check_acl.allow_transfer = "1"b;
	imft_check_acl.objects_to_transfer = "0"b;
	imft_check_acl.found_inner_ring_object = "0"b;
	imft_check_acl.error_code = 0;
	imft_check_acl.error_message = "";
	acl_ptr = imft_check_acl.gen_acl_ptr;

     end init_check_acl;
%page;
CLEANUP:
     proc;

	if star_optionsP ^= null ()
	then do;
		call fs_star_$term (star_optionsP);
		star_optionsP = null ();
		end;

	if afs_ptr ^= null ()
	then do;
		call iox_$close (afs_ptr, ignore_code);
		call iox_$detach_iocb (afs_ptr, ignore_code);
		afs_ptr = null ();
		end;

     end CLEANUP;
%page;

dcl     p_check_acl_ptr	 pointer parameter;
dcl     p_code		 fixed bin (35) parameter;

dcl     ME		 char (32);
dcl     access_str		 character (4);
dcl     accessfile_dname	 char (168) static;
dcl     accessfile_ename	 char (32) static;
dcl     acl_idx		 fixed bin;
dcl     addr		 builtin;
dcl     attach_desc		 char (80);
dcl     afs_ptr		 pointer;
dcl     bad_access_name	 character (32);
dcl     bin		 builtin;
dcl     checking_subtree	 bit (1);
dcl     cleanup		 condition;
dcl     code		 fixed binary (35);
dcl     dir_ring_brackets	 (2) fixed bin (3);
dcl     hbound		 builtin;
dcl     ignore_code		 fixed bin (35);
dcl     local_obj_access_class bit (72) aligned;
dcl     longinfo		 char (100) aligned;
dcl     max_access_class_text	 character (256);
dcl     message_len		 fixed bin (21);
dcl     min_access_class_text	 character (256);
dcl     null		 builtin;
dcl     object_access_class_text
			 character (256);
dcl     object_type		 character (32);
dcl     rtrim		 builtin;
dcl     seg_ring_brackets	 (3) fixed bin (3);
dcl     shortinfo		 character (8) aligned;
dcl     substr		 builtin;
dcl     test_access		 bit (3);
dcl     user_authorization_text
			 character (256);

dcl     error_table_$ai_restricted
			 fixed bin (35) ext static;
dcl     error_table_$lower_ring
			 fixed bin (35) ext static;
dcl     error_table_$moderr	 fixed bin (35) ext static;
dcl     error_table_$unimplemented_version
			 fixed bin (35) ext static;
dcl     error_table_$user_not_found
			 fixed bin (35) ext static;

dcl     aim_check_$greater_or_equal
			 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl     convert_authorization_$to_string_short
			 entry (bit (72) aligned, char (*), fixed bin (35));
dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
dcl     fs_star_$init	 entry (ptr, char (*), char (*), char (8), ptr, fixed bin (35));
dcl     fs_star_$select	 entry (ptr, ptr, fixed bin (35));
dcl     fs_star_$term	 entry (ptr);
dcl     fs_util_$list_acl	 entry (char (*), char (*), char (*), ptr, ptr, fixed bin (35));
dcl     hcs_$get_access_class	 entry (char (*), char (*), bit (72) aligned, fixed bin (35));
dcl     hcs_$get_dir_ring_brackets
			 entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
dcl     hcs_$get_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));
dcl     hcs_$set_bc		 entry (char (*), char (*), fixed bin (24), fixed bin (35));
dcl     hcs_$truncate_file	 entry (char (*), char (*), fixed bin (19), fixed bin (35));
dcl     ioa_$rsnnl		 entry () options (variable);
dcl     iox_$attach_ptr	 entry (ptr, char (*), ptr, fixed bin (35));
dcl     iox_$close		 entry (ptr, fixed bin (35));
dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
dcl     iox_$find_iocb	 entry (char (*), ptr, fixed bin (35));
dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
%page;
%include "_imft_check_acl";
%page;
%include access_mode_values;
%page;
%include acl_structures;
%page;
%include fs_star_;
%page;
%include iox_modes;
     end imft_util_;




		    list_imft_requests.pl1          10/14/88  1248.7rew 10/14/88  1211.3      315063



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

/* Displays status of Inter-Multics File Transfer (IMFT) requests */

/* Created:  April 1982 by G. Palter */
/* Modified: 16 July 1982 by G. Palter to rename "-entry_name" to "-entryname" */
/* Modified: March 1983 by Robert Coren to recognize "-source" and to list all queues by default */
/* Modified: February 23, 1984 by C. Marker to use version 5 message segments */


/****^  HISTORY COMMENTS:
  1) change(88-07-02,Beattie), approve(88-08-01,MCR7948),
     audit(88-10-11,Farley), install(88-10-14,MR12.2-1165):
     Display new options: -delete, -extend and -update.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,ifthenstmt,ifthen */

list_imft_requests:
lir:
     procedure () options (variable);

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  1 local_sb aligned like status_branch;
dcl  1 local_mmi aligned like mseg_message_info;

dcl  1 message_ids (total_message_ids) aligned based (message_ids_ptr),
       2 id bit (72),
       2 position fixed binary,
       2 pad bit (36);
dcl  message_ids_ptr pointer;
dcl  total_message_ids fixed binary;

dcl  argument character (argument_lth) unaligned based (argument_ptr);
dcl  id_qualifier character (id_qualifier_lth) unaligned based (id_qualifier_ptr);
dcl  (the_argument_list, argument_ptr, id_qualifier_ptr) pointer;
dcl  (argument_lth, id_qualifier_lth) fixed binary (21);
dcl  (n_arguments, id_qualifier_idx, argument_idx) fixed binary;

dcl  1 n_selections aligned,
       2 path fixed binary,				/* # of pathname specifiers */
       2 entry fixed binary,				/* # of -entry STR specifiers */
       2 id fixed binary;				/* # of request ID specifiers */
dcl  process_selections bit (1) aligned;

dcl  array_bound fixed binary;

dcl  request_type character (24);
dcl  foreign_system character (24);
dcl  remote bit (1) aligned;
dcl  (queue_indeces, total_requests, selected_requests, first_id_indeces) dimension (4) fixed binary;
dcl  (queue, default_queue, max_queues, queue_idx) fixed binary;
dcl  (generic_type, queue_string) character (32);
dcl  (opened_a_queue, all_queues_empty) bit (1) aligned;

dcl  (output_mode, path_output_mode, id_output_mode, position_mode, user_selection) fixed binary (2);

dcl  (user_id, person_id, project_id) character (32);
dcl  (match_any_person, match_any_project) bit (1) aligned;

dcl  a_dirname character (168);
dcl  an_ename character (32);

dcl  request_id_nonvarying character (19);
dcl  request_id character (19) varying;

dcl  access_required bit (36) aligned;

dcl  message_idx fixed binary;
dcl  first_message_in_queue bit (1) aligned;

dcl  code fixed binary (35);

/* format: off */
dcl (DEFAULT	initial (00b),			/* default setting for control argument */
     BRIEF	initial (01b),			/* -brief */
     LONG		initial (10b),			/* -long */

     NO_POSITION	initial (01b),			/* -no_position */
     SHOW_POSITION	initial (10b),			/* -position */

     TOTALS	initial (11b),			/* -totals */

     USER		initial (01b),			/* -own */
     SUBSET	initial (10b),			/* -user STR */
     ALL		initial (11b),			/* -admin */

     NONE		initial (00b),			/* not a selection control argument */
     PATH		initial (01b),			/* pathname selection */
     ENTRY	initial (10b),			/* -entry STR */
     ID		initial (11b))			/* -id STR */
	fixed binary (2) static options (constant);

dcl (
/*   A_EXTENDED_ACCESS	initial ("400000000000"b3),*/
     O_EXTENDED_ACCESS	initial ("040000000000"b3),
     R_EXTENDED_ACCESS	initial ("100000000000"b3),
     S_EXTENDED_ACCESS	initial ("020000000000"b3))
	bit (36) aligned static options (constant);

dcl  STATE_UNKNOWN fixed binary static options (constant) initial (-1);

dcl  STATE_NAMES (-1:4) character (32) varying static options (constant) initial (
	"unknown",	"unprocessed",	"deferred",	"state changing",
	"eligible",	"running");
/* format: on */

dcl  CHASE fixed binary (1) static options (constant) initial (1);

/*
dcl  READ_FIRST_MESSAGE bit (1) aligned static options (constant) initial ("0"b);
dcl  READ_THIS_MESSAGE bit (2) aligned static options (constant) initial ("00"b);
*/
dcl  READ_NEXT_MESSAGE bit (2) aligned static options (constant) initial ("01"b);

dcl  LIST_IMFT_REQUESTS character (32) static options (constant) initial ("list_imft_requests");

dcl  imft_data_$queue_dirname character (168) external;

/* format: off */
dcl (error_table_$bad_segment, error_table_$badopt, error_table_$id_not_found, error_table_$inconsistent,
     error_table_$moderr, error_table_$no_message, error_table_$no_s_permission, error_table_$noarg)
	fixed binary (35) external;
/* format: on */

dcl  check_star_name_$entry entry (character (*), fixed binary (35));
dcl  com_err_ entry () options (variable);
dcl  cu_$arg_count entry (fixed binary, fixed binary (35));
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl  date_time_ entry (fixed binary (71), character (*));
dcl  expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35));
dcl  get_group_id_ entry () returns (character (32));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  hcs_$status_long entry (character (*), character (*), fixed binary (1), pointer, pointer, fixed binary (35));
dcl  imft_default_rqt_ entry () returns (char (*));
dcl  ioa_ entry () options (variable);
dcl  iod_info_$generic_type entry (character (*), character (32), fixed binary (35));
dcl  iod_info_$queue_data entry (character (*), fixed binary, fixed binary, fixed binary (35));
dcl  match_request_id_ entry (fixed binary (71), character (*)) returns (bit (1) aligned);
dcl  match_star_name_ entry (character (*), character (*), fixed binary (35));
dcl  message_segment_$close entry (fixed binary, fixed binary (35));
dcl  message_segment_$get_message_count_index entry (fixed binary, fixed binary, fixed binary (35));
dcl  message_segment_$get_mode_index entry (fixed binary, bit (36) aligned, fixed binary (35));
dcl  message_segment_$open entry (character (*), character (*), fixed binary, fixed binary (35));
dcl message_segment_$read_message_index entry (fixed binary, pointer, pointer, fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  request_id_ entry (fixed binary (71)) returns (character (19));

dcl  cleanup condition;

dcl  (addr, after, before, convert, index, length, max, null, rtrim, substr, sum, unspec, verify) builtin;

/**/

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

	the_argument_list = cu_$arg_list_ptr ();


/* Establish defaults */

	array_bound = max (n_arguments, 1);		/* PL/I abhors a vacuum */

	n_selections = 0;				/* no path, entry, or ID selections */

	request_type = imft_default_rqt_ ();		/* returns real name of default request type */
	queue = -1;				/* list all queues by default */

	output_mode = BRIEF;			/* default is -brief */
	path_output_mode = DEFAULT;			/* default is -absp if -long and -etnm if -brief */
	id_output_mode = DEFAULT;			/* default is -short_id if -brief and -long_id if -long */
	position_mode = DEFAULT;			/* default is -no_position */
	user_selection = USER;			/* default is -own */

MAIN_LIR_BLOCK:
	begin;

dcl  selection_types (array_bound) fixed binary (2);	/* type of selection indicated by this argument */
dcl  dir_uids (array_bound) bit (36) aligned;		/* UIDs of directory part of pathname selections */

	     selection_types (*) = NONE;
	     dir_uids (*) = ""b;
	     id_qualifier_idx = 0;			/* index of first -id STR */


/* Scan the argument list, verify the syntax of all request_identifiers, process all control arguments, and apply other
   appropriate defaults */

	     do argument_idx = 1 to n_arguments;

		call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, the_argument_list);
		if code ^= 0 then do;
		     call com_err_ (code, LIST_IMFT_REQUESTS, "Accessing argument #^d.", argument_idx);
		     return;
		end;

		if index (argument, "-") = 1 then	/* a control argument */
		     if (argument = "-destination") | (argument = "-ds") then do;
			remote = "0"b;
			go to FOREIGN_SYSTEM;
		     end;

		     else if (argument = "-source") | (argument = "-sc") then do;
			remote = "1"b;
FOREIGN_SYSTEM:
			call get_next_argument ("A system name", foreign_system);
			if remote then
			     request_type = substr ("From_" || foreign_system, 1, length (request_type));
			else request_type = substr ("To_" || foreign_system, 1, length (request_type));

			call iod_info_$generic_type (request_type, generic_type, code);
			if code ^= 0 then do;	/* couldn't lookup the specified destination */
INVALID_DESTINATION_SPECIFICATION:
			     if code = error_table_$id_not_found then
				call com_err_ (0, LIST_IMFT_REQUESTS, "Unknown ^[source^;destination^].  ""^a""",
				     remote, foreign_system);
			     else call com_err_ (code, LIST_IMFT_REQUESTS, "-^[source^;destination^] ""^a""",
				     remote, foreign_system);
			     return;
			end;
			if generic_type ^= FT_GENERIC_TYPE then do;
			     call com_err_ (0, LIST_IMFT_REQUESTS, "Unknown ^[source^;destination^].  ""^a""",
				remote, foreign_system);
			     return;
			end;
		     end;

		     else if (argument = "-queue") | (argument = "-q") then do;
			call get_next_argument ("A number", queue_string);
			queue = cv_dec_check_ (queue_string, code);
			if code ^= 0 then do;
INVALID_QUEUE_SPECIFICATION:
			     call com_err_ (0, LIST_IMFT_REQUESTS,
				"The queue must be a number between 1 and 4; not ""^a"".", queue_string);
			     return;
			end;
			if (queue < 1) | (queue > 4) then go to INVALID_QUEUE_SPECIFICATION;
		     end;				/* will check if queue is OK for destination later */

		     else if (argument = "-all") | (argument = "-a") then queue = -1;
						/* special indicator to match all queues */

		     else if (argument = "-brief") | (argument = "-bf") then output_mode = BRIEF;
		     else if (argument = "-long") | (argument = "-lg") then output_mode = LONG;
		     else if (argument = "-totals") | (argument = "-total") | (argument = "-tt") then
			output_mode = TOTALS;

		     else if (argument = "-absolute_pathname") | (argument = "-absp") then path_output_mode = LONG;
		     else if (argument = "-entryname") | (argument = "-etnm") then path_output_mode = BRIEF;

		     else if (argument = "-long_id") | (argument = "-lgid") then id_output_mode = LONG;
		     else if (argument = "-short_id") | (argument = "-shid") then id_output_mode = BRIEF;

		     else if (argument = "-position") | (argument = "-psn") then position_mode = SHOW_POSITION;
		     else if (argument = "-no_position") | (argument = "-npsn") then position_mode = NO_POSITION;

		     else if argument = "-own" then user_selection = USER;
		     else if (argument = "-admin") | (argument = "-am") then user_selection = ALL;
		     else if argument = "-user" then do;
			call get_next_argument ("A user ID", user_id);
			if after (after (user_id, "."), ".") ^= "" then do;
			     call com_err_ (0, LIST_IMFT_REQUESTS, "Improper syntax for user ID.  ""^a""", user_id);
			     return;
			end;
			match_any_person = (before (user_id, ".") = "") | (before (user_id, ".") = "*");
			match_any_project = (after (user_id, ".") = "") | (after (user_id, ".") = "*");
			if match_any_person & match_any_project then
			     user_selection = ALL;
			else do;			/* matches a subset of all users */
			     user_selection = SUBSET;
			     person_id = before (user_id, ".");
			     project_id = after (user_id, ".");
			     if person_id = "" then person_id = "*";
			     if project_id = "" then project_id = "*";
			end;
		     end;

		     else if (argument = "-entry") | (argument = "-et") then do;
			call get_next_argument ("A starname", an_ename);
			call check_star_name_$entry (an_ename, code);
			if (code ^= 0) & (code ^= 1) & (code ^= 2) then do;
			     call com_err_ (code, LIST_IMFT_REQUESTS, "^a", an_ename);
			     return;
			end;
			n_selections.entry = n_selections.entry + 1;
			selection_types (argument_idx) = ENTRY;
		     end;

		     else if argument = "-id" then do;
			call get_next_argument ("A request ID match string", request_id_nonvarying);
			request_id = rtrim (request_id_nonvarying);
			if verify (request_id, "0123456789.") ^= 0 then do;
INVALID_REQUEST_ID:
			     call com_err_ (0, LIST_IMFT_REQUESTS,
				"Improper syntax for a request ID match string.  ""^a""", request_id);
			     return;
			end;
			if after (after (request_id, "."), ".") ^= "" then go to INVALID_REQUEST_ID;
			if length (before (request_id, ".")) > length ("YYMMDDHHMMSS") then
			     go to INVALID_REQUEST_ID;
			if length (after (request_id, ".")) > length ("FFFFFF") then go to INVALID_REQUEST_ID;
			n_selections.id = n_selections.id + 1;
			selection_types (argument_idx) = ID;
			if id_qualifier_idx = 0 then id_qualifier_idx = argument_idx;
		     end;				/* record index of first -id STR */

		     else do;
			call com_err_ (error_table_$badopt, LIST_IMFT_REQUESTS, """^a""", argument);
			return;
		     end;

		else do;				/* a pathname selection */
		     call expand_pathname_ (argument, a_dirname, an_ename, code);
		     if code ^= 0 then do;
			call com_err_ (code, LIST_IMFT_REQUESTS, "^a", argument);
			return;
		     end;
		     call check_star_name_$entry (an_ename, code);
		     if (code ^= 0) & (code ^= 1) & (code ^= 3) then do;
			call com_err_ (code, LIST_IMFT_REQUESTS, pathname_ (a_dirname, an_ename));
			return;
		     end;
		     n_selections.path = n_selections.path + 1;
		     selection_types (argument_idx) = PATH;
		     call hcs_$status_long (a_dirname, "", CHASE, addr (local_sb), null (), code);
		     if (code = 0) | (code = error_table_$no_s_permission) then
			dir_uids (argument_idx) = local_sb.uid;
		end;				/* get the UID now: will need it later */
	     end;

	     if (output_mode = TOTALS)
		& ((path_output_mode ^= DEFAULT) | (id_output_mode ^= DEFAULT) | (position_mode ^= DEFAULT)) then do;
		if path_output_mode ^= DEFAULT then
		     call com_err_ (error_table_$inconsistent, LIST_IMFT_REQUESTS,
			"""-total"" and ""^[-entryname^;absolute_pathname^]""", (path_output_mode = BRIEF));
		if id_output_mode ^= DEFAULT then
		     call com_err_ (error_table_$inconsistent, LIST_IMFT_REQUESTS,
			"""-total"" and ""^[-short_id^;long_id^]""", (id_output_mode = BRIEF));
		if position_mode ^= DEFAULT then
		     call com_err_ (error_table_$inconsistent, LIST_IMFT_REQUESTS,
			"""-total"" and ""^[-no_position^;-position^]""", (position_mode = NO_POSITION));
		return;
	     end;

	     if path_output_mode = DEFAULT then path_output_mode = output_mode;
	     if id_output_mode = DEFAULT then id_output_mode = output_mode;
	     if position_mode = DEFAULT then position_mode = NO_POSITION;

	     if ((n_selections.entry + n_selections.path) > 0) & (n_selections.id > 1) then do;
		call com_err_ (error_table_$inconsistent, LIST_IMFT_REQUESTS,
		     "More than one ""-id"" control argument with path/entry selections.");
		return;
	     end;

	     call iod_info_$queue_data (request_type, default_queue, max_queues, code);
	     if code ^= 0 then go to INVALID_DESTINATION_SPECIFICATION;

	     if queue = 0 then queue = default_queue;	/* supply default if needed */
	     if queue > max_queues then do;
		call com_err_ (0, LIST_IMFT_REQUESTS,
		     "^[Source^;Destination^] ^a has only ^d queue^[s^]; you specified queue ^d.", remote, request_type, max_queues,
		     (max_queues ^= 1), queue);
		return;
	     end;

/**/

/* Fetch the next argument */

get_next_argument:
     procedure (p_arg_description, p_argument);

dcl  p_arg_description character (*) parameter;
dcl  p_argument character (*) parameter;
dcl  control_argument character (32);

	control_argument = argument;			/* save control arg's name for error messages */

	if argument_idx = n_arguments then do;		/* there is no next argument */
	     call com_err_ (error_table_$noarg, LIST_IMFT_REQUESTS, "^a must follow ""^a"".", p_arg_description,
		control_argument);
	     go to ABORT_ARGUMENT_PARSE;
	end;

	argument_idx = argument_idx + 1;

	call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, the_argument_list);
	if code ^= 0 then do;
	     call com_err_ (code, LIST_IMFT_REQUESTS, "Accessing argument #^d.", argument_idx);
	     go to ABORT_ARGUMENT_PARSE;
	end;

	if argument_lth > length (p_argument) then do;	/* it's too long */
	     call com_err_ (0, LIST_IMFT_REQUESTS, "Value after ""^a"" may not be longer than ^d characters.  ""^a""",
		control_argument, length (p_argument), argument);
	     go to ABORT_ARGUMENT_PARSE;
	end;

	p_argument = argument;			/* it's OK */

	return;

     end get_next_argument;

/**/

/* Argument parsing completed: open the appropriate queues and determine if the user has sufficient access */

	     system_area_ptr = get_system_free_area_ ();

	     queue_indeces (*) = 0;			/* for cleanup handler */
	     message_ids_ptr, ft_request_ptr = null ();

	     unspec (local_mmi) = ""b;
	     local_mmi.version = MSEG_MESSAGE_INFO_V1;

	     on condition (cleanup) call cleanup_handler ();

	     if (position_mode = SHOW_POSITION) & (user_selection = USER) then do;
		person_id = before (get_group_id_ (), ".");
		project_id = "*";			/* need to match just this user */
	     end;

	     if (position_mode = SHOW_POSITION) | (user_selection ^= USER) then access_required = R_EXTENDED_ACCESS;

	     else do;
		access_required = O_EXTENDED_ACCESS;
		local_mmi.own = "1"b;
	     end;

	     total_requests (*) = -1;			/* don't know what's in any of the queues yet */

	     if queue = -1 then do;			/* want to examine all the queues */
		opened_a_queue = "0"b;
		do queue_idx = 1 to max_queues;
		     call open_single_queue (queue_idx);
		     if queue_indeces (queue_idx) ^= 0 then opened_a_queue = "1"b;
		end;
		if ^opened_a_queue then go to RETURN_FROM_LIST_IMFT_REQUESTS;
	     end;

	     else do;				/* just one queue please */
		call open_single_queue (queue);
		if queue_indeces (queue) = 0 then go to RETURN_FROM_LIST_IMFT_REQUESTS;
	     end;					/* couldn't open it: nothing we can do */

/**/

/* Opens a single queue's message segment and validates access */

open_single_queue:
     procedure (p_queue_number);

dcl  p_queue_number fixed binary parameter;
dcl  queue_ename character (32);
dcl  queue_picture picture "9";
dcl  queue_mode bit (36) aligned;

	queue_ename = rtrim (request_type) || "_" || convert (queue_picture, p_queue_number) || ".ms";

	call message_segment_$open (imft_data_$queue_dirname, queue_ename, queue_indeces (p_queue_number), code);
	if code ^= 0 then do;
	     call com_err_ (code, LIST_IMFT_REQUESTS, "Opening ^a.", pathname_ (imft_data_$queue_dirname, queue_ename));
	     go to RETURN_FROM_LIST_IMFT_REQUESTS;
	end;

	call message_segment_$get_mode_index (queue_indeces (p_queue_number), queue_mode, code);
	if code ^= 0 then do;
	     call com_err_ (code, LIST_IMFT_REQUESTS, "Determining access to ^a.",
		pathname_ (imft_data_$queue_dirname, queue_ename));
	     go to RETURN_FROM_LIST_IMFT_REQUESTS;
	end;

	if (queue_mode & access_required) ^= access_required then do;
	     call com_err_ (error_table_$moderr, LIST_IMFT_REQUESTS,
		"You do not have ""^[r^;o^]"" access to ^a queue ^d.", (access_required = R_EXTENDED_ACCESS),
		request_type, p_queue_number);
	     call message_segment_$close (queue_indeces (p_queue_number), (0));
	     queue_indeces (p_queue_number) = 0;	/* not fatal: just don't list this queue */
	     return;
	end;

	if (queue_mode & S_EXTENDED_ACCESS) = S_EXTENDED_ACCESS then do;
	     call message_segment_$get_message_count_index (queue_indeces (p_queue_number),
		total_requests (p_queue_number), code);
	     if code ^= 0 then			/* couldn't get the message count: not fatal */
		call com_err_ (code, LIST_IMFT_REQUESTS, "Determining number of messages in ^a.",
		     pathname_ (imft_data_$queue_dirname, queue_ename));
	end;

	return;

     end open_single_queue;

/**/

/* Scan each of the selected queues generating a list of matching requests */

	     first_id_indeces (*) = 0;		/* index into message_ids array of first request in queue */
	     selected_requests (*) = 0;

	     call get_temp_segment_ (LIST_IMFT_REQUESTS, message_ids_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, LIST_IMFT_REQUESTS, "Getting a temporary segment.");
		go to RETURN_FROM_LIST_IMFT_REQUESTS;
	     end;

	     total_message_ids = 0;			/* haven't used any yet */

	     process_selections = ((n_selections.path + n_selections.entry + n_selections.id) ^= 0);

	     if ((n_selections.path + n_selections.entry) > 0) & (n_selections.id = 1) then
		call cu_$arg_ptr_rel (id_qualifier_idx, id_qualifier_ptr, id_qualifier_lth, (0), the_argument_list);
	     else do;				/* no -id STR qualifier present: avoid faults */
		id_qualifier_ptr = addr (LIST_IMFT_REQUESTS);
		id_qualifier_lth = 0;
	     end;

	     do queue_idx = 1 to max_queues;		/* scan each queue that's open */
		if queue_indeces (queue_idx) ^= 0 then call scan_single_queue (queue_idx);
	     end;

	     if sum (selected_requests (*)) = 0 then do;	/* no matching requests were found */
		all_queues_empty = "1"b;		/* ... assume thery're all empty */
		do queue_idx = 1 to max_queues while (all_queues_empty);
		     if total_requests (queue_idx) ^= 0 then all_queues_empty = "0"b;
		end;
		if all_queues_empty then		/* ... and there's nothing in any of the queues */
		     call ioa_ ("There are no requests in any ^a queue.", request_type);
		else do;				/* ... explain about each empty queue */
		     do queue_idx = 1 to max_queues;
			if queue_indeces (queue_idx) ^= 0 then
			     call ioa_ ("^/^a queue ^d:^-^[0 requests^]^[; ^]^[^d total request^[s^]^].",
				request_type, queue_idx, (total_requests (queue_idx) ^= 0),
				(total_requests (queue_idx) > 0), (total_requests (queue_idx) ^= -1),
				total_requests (queue_idx), (total_requests (queue_idx) ^= 1));
		     end;
		     call ioa_ ("");
		end;
		go to RETURN_FROM_LIST_IMFT_REQUESTS;
	     end;

/**/

/* Scans a single queue and records the indeces of all requests matching the selection criteria */

scan_single_queue:
     procedure (p_queue_number);

dcl  p_queue_number fixed binary parameter;

dcl  user_id character (30);
dcl  position fixed binary;
dcl  previous_message_id bit (72) aligned;
dcl  request_uid bit (36) aligned;
dcl  (retry_read, matches) bit (1) aligned;

	position = 0;

	retry_read = "0"b;				/* this isn't a retry */

RETRY_FIRST_READ:
	local_mmi.message_code = MSEG_READ_FIRST;
	call message_segment_$read_message_index (queue_indeces (p_queue_number), system_area_ptr, addr (local_mmi), code);
	if ^retry_read then
	     if code = error_table_$bad_segment then do;
		retry_read = "1"b;			/* queue might have been salvaged: try again */
		go to RETRY_FIRST_READ;
	     end;


	do while (code = 0);			/* while we've got a message */

	     previous_message_id = local_mmi.ms_id;	/* needed to read the next message */
	     position = position + 1;			/* count the messages as we read them */

	     ft_request_ptr = local_mmi.ms_ptr;

	     user_id = substr (local_mmi.sender_id, 1, (length (rtrim (local_mmi.sender_id)) - 2));

	     if (ft_request.hdr_version ^= queue_msg_hdr_version_1) | (ft_request.version ^= FT_REQUEST_VERSION_1)
	     then do;				/* unrecognized message format */
		if (user_selection ^= USER) | (position_mode = SHOW_POSITION) then do;
		     if user_selection ^= ALL then do;	/* ... check if it's from an interesting user */
			if person_id ^= "*" then
			     if before (user_id, ".") ^= person_id then go to SKIP_THIS_MESSAGE;
			if project_id ^= "*" then
			     if after (user_id, ".") ^= project_id then go to SKIP_THIS_MESSAGE;
		     end;
		end;
		call add_this_message ();		/* it's the right user anyway */
		go to SKIP_THIS_MESSAGE;
	     end;

	     if (user_selection ^= USER) | (position_mode = SHOW_POSITION) then do;
		if user_selection ^= ALL then do;	/* must check if the user IDs match */
		     if person_id ^= "*" then
			if before (user_id, ".") ^= person_id then go to SKIP_THIS_MESSAGE;
		     if project_id ^= "*" then
			if after (user_id, ".") ^= project_id then go to SKIP_THIS_MESSAGE;
		end;
	     end;

	     if process_selections then do;		/* have to match path/entry/request ID */
		matches = "0"b;			/* until proven otherwise */
		do argument_idx = 1 to n_arguments while (^matches);
		     if selection_types (argument_idx) ^= NONE then do;
			call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, (0), the_argument_list);
			if (selection_types (argument_idx) = PATH) | (selection_types (argument_idx) = ENTRY)
			then do;
			     if selection_types (argument_idx) = PATH then
				call expand_pathname_ (argument, a_dirname, an_ename, (0));
			     else an_ename = argument;
			     call match_star_name_ ((ft_request.ename), an_ename, code);
			     if code = 0 then	/* entry names match ... */
				if selection_types (argument_idx) = PATH then do;
				     call hcs_$status_long ((ft_request.dirname), "", CHASE, addr (local_sb),
					null (), code);
				     if (code = 0) | (code = error_table_$no_s_permission) then
					request_uid = local_sb.uid;
				     else request_uid = ""b;
				     if (request_uid ^= ""b) & (dir_uids (argument_idx) ^= ""b) then
					matches = (request_uid = dir_uids (argument_idx));
				     else if (request_uid = ""b) & (dir_uids (argument_idx) = ""b) then
					matches = (ft_request.dirname = a_dirname);
				end;
				else matches = "1"b;
			     if matches & (id_qualifier ^= "") then
				matches = match_request_id_ (ft_request.msg_time, id_qualifier);
			end;
			else do;			/* a request ID: only if not using ID as a qualifier */
			     if id_qualifier = "" then matches = match_request_id_ (ft_request.msg_time, argument);
			end;
		     end;
		end;
		if ^matches then go to SKIP_THIS_MESSAGE;
	     end;

	     call add_this_message ();		/* it passes all the selection criteria */

SKIP_THIS_MESSAGE:
	     free ft_request in (system_area);		/* done with this request for now */
	     ft_request_ptr = null ();

	     retry_read = "0"b;			/* first attempt to read the next message */

RETRY_READ_NEXT_MESSAGE:
	     local_mmi.message_code = MSEG_READ_AFTER_SPECIFIED;
	     local_mmi.ms_id = previous_message_id;

	     call message_segment_$read_message_index (queue_indeces (p_queue_number), system_area_ptr, addr (local_mmi), code);
	     if ^retry_read then
		if code = error_table_$bad_segment then do;
		     retry_read = "1"b;		/* message segment may have been salvaged */
		     go to RETRY_READ_NEXT_MESSAGE;
		end;
	end;

	if (code ^= 0) & (code ^= error_table_$no_message) then do;
	     call com_err_ (code, LIST_IMFT_REQUESTS, "Reading from ^a queue ^d.", request_type, p_queue_number);
	     call message_segment_$close (queue_indeces (p_queue_number), (0));
	     queue_indeces (p_queue_number) = 0;	/* fatal error while reading: drop this queue */
	end;

	return;


/* Internal to scan_single_queue: adds the current request to the list of selected requests */

add_this_message:
	procedure ();

	     selected_requests (p_queue_number) = selected_requests (p_queue_number) + 1;

	     total_message_ids = total_message_ids + 1;

	     message_ids.id (total_message_ids) = local_mmi.ms_id;
	     message_ids.position (total_message_ids) = position;

	     if first_id_indeces (p_queue_number) = 0 then first_id_indeces (p_queue_number) = total_message_ids;

	     return;

	end add_this_message;

     end scan_single_queue;

/**/

/* Display the descriptions of each matching request */

	     do queue_idx = 1 to max_queues;

		if queue_indeces (queue_idx) ^= 0 then do;

		     if (selected_requests (queue_idx) ^= 0) | (total_requests (queue_idx) > 0) then
			call ioa_ ("^/^a queue ^d:^-^d request^[s^]^[; ^d total request^[s^]^].", request_type,
			     queue_idx, selected_requests (queue_idx), (selected_requests (queue_idx) ^= 1),
			     (total_requests (queue_idx) ^= -1), total_requests (queue_idx),
			     (total_requests (queue_idx) ^= 1));

		     if output_mode ^= TOTALS then do;	/* some requests to display */
			first_message_in_queue = "1"b;
			do message_idx = first_id_indeces (queue_idx)
			     to (first_id_indeces (queue_idx) + selected_requests (queue_idx) - 1);
			     call display_single_request (queue_idx, message_ids.id (message_idx),
				message_ids.position (message_idx));
			end;
		     end;
		end;
	     end;

	     if (output_mode ^= LONG) | first_message_in_queue then call ioa_ ("");

/**/

/* Displays a single request's description */

display_single_request:
     procedure (p_queue, p_message_id, p_position);

dcl  (p_queue, p_position) fixed binary parameter;
dcl  p_message_id bit (72) aligned parameter;

dcl  user_id character (30);
dcl  time_queued_string character (24);
dcl  long_id_string character (19);
dcl  short_id_string character (8);
dcl  (retry_read, supported_version) bit (1) aligned;

	retry_read = "0"b;

READ_THE_MESSAGE:
	local_mmi.message_code = MSEG_READ_SPECIFIED;
	local_mmi.ms_id = p_message_id;

	call message_segment_$read_message_index (queue_indeces (p_queue), system_area_ptr, addr (local_mmi), code);
	if retry_read then
	     if code = error_table_$bad_segment then do;
		retry_read = "1"b;			/* message segment has been salvaged */
		go to READ_THE_MESSAGE;
	     end;

	if code ^= 0 then do;			/* couldn't get the message: OK if it was deleted */
	     if code ^= error_table_$no_message then
		call com_err_ (code, LIST_IMFT_REQUESTS, "Attempting to read message ^24.3b from ^a queue ^d.",
		     p_message_id, request_type, p_queue);
	     return;
	end;

	ft_request_ptr = local_mmi.ms_ptr;

	user_id = substr (local_mmi.sender_id, 1, (length (rtrim (local_mmi.sender_id)) - 2));

	if (ft_request.hdr_version ^= queue_msg_hdr_version_1) | (ft_request.version ^= FT_REQUEST_VERSION_1) then do;
	     supported_version = "0"b;		/* unknown message */
	     unspec (ft_request.msg_time) = local_mmi.ms_id;
	     call date_time_ (ft_request.msg_time, time_queued_string);
	end;

	else do;
	     supported_version = "1"b;		/* we recognize this message */
	     if (ft_request.state < STATE_UNPROCESSED) | (ft_request.state > STATE_RUNNING) then
		ft_request.state = STATE_UNKNOWN;	/* ... but the state is garbage so "fix" it */
	     long_id_string = request_id_ (ft_request.msg_time);
	     short_id_string = substr (long_id_string, 7, 8);
	     call date_time_ (ft_request.msg_time, time_queued_string);
	end;

	if first_message_in_queue then do;
	     first_message_in_queue = "0"b;
	     call ioa_ ("");			/* put some space after the totals line */
	     if (user_selection ^= USER) & (output_mode = BRIEF) then
		call ioa_ ("User^31t^[^7x^]^2xID^[^19x^;^8x^]^[Entry name^;Pathname^]",
		     (position_mode = SHOW_POSITION), (id_output_mode = LONG), (path_output_mode = BRIEF));
	end;

	if output_mode = BRIEF then
	     if supported_version then
		call ioa_ ("^[^30a^;^s^]^[^6d)^;^s^]^2x^[^a^s^;^s^a^]^2x^[^a^s^;^s^a^]^[ (^a)^]",
		     (user_selection ^= USER), user_id, (position_mode = SHOW_POSITION), p_position,
		     (id_output_mode = BRIEF), short_id_string, long_id_string, (path_output_mode = BRIEF),
		     ft_request.ename, pathname_ ((ft_request.dirname), (ft_request.ename)),
		     (ft_request.state ^= STATE_UNPROCESSED), STATE_NAMES (ft_request.state));

	     else call ioa_ ("^[^30a^;^s^] (unrecognized request format); time queued: ^a", (user_selection ^= USER),
		     user_id, time_queued_string);

	else do;					/* long output format */
	     if supported_version then do;
		if user_selection ^= USER then call ioa_ ("User:^21t^a", user_id);
		if position_mode = SHOW_POSITION then call ioa_ ("Position in queue:^21t^d", p_position);
		call ioa_ ("Request ID:^21t^[^a^;^s^a^]", (id_output_mode = BRIEF), short_id_string, long_id_string);
		call ioa_ ("Time queued:^21t^a", time_queued_string);
		call ioa_ ("^[Local ^[entry^;pathname^]^;^[Entry^;Pathname^]^]:^21t^[^a^;^s^a^]",
		     ft_request.foreign_path_given, (path_output_mode = BRIEF), (path_output_mode = BRIEF),
		     ft_request.ename, pathname_ ((ft_request.dirname), (ft_request.ename)));
		call ioa_ ("State:^21t^a", STATE_NAMES (ft_request.state));
		if ft_request.foreign_path_given then
		     call ioa_ ("Foreign pathname:^21t^a",
			pathname_ (ft_request.foreign_dirname, ft_request.foreign_ename));
		if ft_request.foreign_user_given then call ioa_ ("Foreign user:^21t^a", ft_request.foreign_user);
		if (ft_request.directory_creation_mode ^= "00"b) then
		     call ioa_ ("Options:^21t^[replace_directories^;merge_directories^]",
			(ft_request.directory_creation_mode = REPLACE_DIRECTORIES));
		if ft_request.delete then call ioa_ ("Delete:^21tyes");
		if ft_request.extend then call ioa_ ("Extend:^21tyes");
		if ft_request.notify then call ioa_ ("Notify:^21tyes");
		if ft_request.update then call ioa_ ("Update:^21tyes");
	     end;
	     else do;				/* unrecognized message format */
		call ioa_ ("User:^21t^a", user_id);
		call ioa_ ("Time queued:^21t^a", time_queued_string);
		call ioa_ ("^5x(unrecognized request format)");
	     end;
	     call ioa_ ("");			/* and end it with a blank line */
	end;

	free ft_request in (system_area);
	ft_request_ptr = null ();

	return;

     end display_single_request;

	end MAIN_LIR_BLOCK;

/**/

RETURN_FROM_LIST_IMFT_REQUESTS:
	call cleanup_handler ();

ABORT_ARGUMENT_PARSE:
	return;


/* Cleanup after an invocation of list_imft_requests */

cleanup_handler:
     procedure ();

	if ft_request_ptr ^= null () then do;
	     free ft_request in (system_area);
	     ft_request_ptr = null ();
	end;

	if message_ids_ptr ^= null () then do;
	     call release_temp_segment_ (LIST_IMFT_REQUESTS, message_ids_ptr, (0));
	     message_ids_ptr = null ();
	end;

	do queue_idx = 1 to max_queues;
	     if queue_indeces (queue_idx) ^= 0 then do;
		call message_segment_$close (queue_indeces (queue_idx), (0));
		queue_indeces (queue_idx) = 0;
	     end;
	end;

	return;

     end cleanup_handler;

/**/

%include "_imft_ft_request";
%page;
%include mseg_message_info;
%page;
%include queue_msg_hdr;
%page;
%include status_structures;

     end list_imft_requests;




		    old_imft_io_.pl1                10/14/88  1248.7r w 10/14/88  1214.6      447327



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


/* I/O module to transmit files between Multics sites using I/O daemon record oriented communications modules */

/* Created:  October 1980 by G. Palter */
/* Modified: April 1982 by G. Palter to greatly simplify attach description and internal operation */
/* Modified: 26 July 1982 by G. Palter to add get_channel_names control order */
/* Modified: February 1983 by Robert Coren to change from imft_io_ to old_imft_io_ */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */


old_imft_io_:
     procedure ();
	return;					/* not an entry */


/* Parameters */

dcl  P_iocb_ptr pointer parameter;			/* *: -> I/O switch being operated upon */
dcl  P_code fixed binary (35) parameter;

dcl  P_attach_options (*) character (*) varying parameter;	/* attach: attachment arguments */
dcl  P_loud_sw bit (1) parameter;			/* attach: ON => attachment errors should call com_err_ */

dcl  P_open_mode fixed binary parameter;		/* open: opening mode */
dcl  P_open_sw bit (1) parameter;			/* open: obsolete parameter */

dcl  P_data_lth fixed binary (21) parameter;		/* get_*: set to # of characters read into buffer;
						   put_chars: # of characters to transmit as logical record */

dcl  P_buffer_ptr pointer parameter;			/* get_*: -> area to place result of read */
dcl  P_buffer_max_lth fixed binary (21) parameter;	/* get_*: size of area in characters */

dcl  P_data_ptr pointer parameter;			/* put_chars: -> data stream to be written */

dcl  P_order character (*) parameter;			/* control: name of control order to be performed */
dcl  P_info_ptr pointer parameter;			/* control: -> additional information required to execute the
						   control order */

dcl  P_new_modes character (*) parameter;		/* modes: new modes to be set */
dcl  P_old_modes character (*) parameter;		/* modes: set to modes in effect before change */


/* Local copies of parameters */

dcl  iocb_ptr pointer;
dcl  code fixed binary (35);

dcl  argument character (argument_lth) based (argument_ptr);/* based on attach options */
dcl  argument_lth fixed binary (21);
dcl  argument_ptr pointer;

dcl  loud_sw bit (1) aligned;

dcl  open_mode fixed binary;

dcl  buffer_lth fixed binary (21);

dcl  order character (32);
dcl  info_ptr pointer;


/* Remaining declarations */

dcl  1 local_tgci aligned like tty_get_channel_info;	/* for get_channel_names */

dcl  system_area area aligned based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  argument_idx fixed binary;			/* # of attach option being processed */

dcl  direction character (32);
dcl  (input_description_idx, output_description_idx) fixed binary;

dcl  an_attach_description character (512);

dcl  terminal_switch_name character (32);
dcl  terminal_iocb_ptr pointer;
dcl  terminal_attach_count fixed binary static initial (0);
dcl  terminal_attach_count_pic picture "999";

dcl  ips_mask bit (36);

dcl  local_record_type fixed binary;

dcl  IMFT_IO_ character (32) static options (constant) initial ("old_imft_io_");

dcl  N_BITS_PER_CHARACTER fixed binary static options (constant) initial (9);

dcl  RELATIVE_SECONDS bit (2) static options (constant) initial ("11"b);
dcl  ONE_MINUTE fixed binary (71) static options (constant) initial (60);

dcl  SP character (1) static options (constant) initial (" ");

/* format: off */
dcl (error_table_$action_not_performed, error_table_$badopt, error_table_$bad_arg, error_table_$bad_conversion,
     error_table_$bad_mode, error_table_$eof_record, error_table_$improper_data_format, error_table_$invalid_read,
     error_table_$invalid_write, error_table_$noarg, error_table_$no_operation, error_table_$not_attached,
     error_table_$not_closed, error_table_$not_detached, error_table_$not_open, error_table_$null_info_ptr,
     error_table_$short_record, error_table_$undefined_order_request, error_table_$unimplemented_version)
	fixed binary (35) external;

dcl (imft_et_$cant_get_channel_names, imft_et_$reply_pending, imft_et_$timeout)
	fixed binary (35) external;
/* format: on */

dcl  add_bit_offset_ entry (pointer, fixed binary (24)) returns (pointer);
dcl  com_err_ entry () options (variable);
dcl  continue_to_signal_ entry (fixed binary (35));
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$reset_ips_mask entry (bit (36), bit (36));
dcl  hcs_$set_ips_mask entry (bit (36), bit (36));
dcl  ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1));
dcl  iox_$attach_ioname entry (character (*), pointer, character (*), fixed binary (35));
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  iox_$close entry (pointer, fixed binary (35));
dcl  iox_$destroy_iocb entry (pointer, fixed binary (35));
dcl  iox_$detach_iocb entry (pointer, fixed binary (35));
dcl  iox_$err_no_operation entry () options (variable);
dcl  iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35));
dcl  iox_$propagate entry (pointer);
dcl  iox_$read_record entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35));
dcl  iox_$write_record entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  requote_string_ entry (character (*)) returns (character (*));
dcl  timer_manager_$alarm_call entry (fixed binary (71), bit (2), entry);
dcl  timer_manager_$reset_alarm_call entry (entry);

dcl  (any_other, cleanup, imft_debug_, imft_read_abort_, imft_write_abort_) condition;

dcl  (addr, collate, convert, currentsize, divide, hbound, lbound, length, ltrim, min, mod, null, rtrim, string, substr,
     verify, unspec) builtin;

/**/

/* Description of a switch attached through this module */

dcl  1 iad aligned based (iad_ptr),
       2 attach_description character (1024) varying,	/* attach description for this I/O switch */
       2 open_description character (24) varying,		/* open description for this I/O switch */
       2 input_switch like switch_info,			/* defines the input terminal switch */
       2 output_switch like switch_info,		/* defines the output terminal switch */
       2 abort_code fixed binary (35),			/* status code of last aborted I/O operation */
       2 flags aligned,
         3 input_direction bit (1) unaligned,		/* ON => receives data from remote system */
         3 abort_in_progress bit (1) unaligned,		/* ON => last I/O operation failed */
         3 debug_mode bit (1) unaligned,		/* ON => trying to debug IMFT: stop on errors */
         3 pad bit (33) unaligned;

dcl  iad_ptr pointer;


/* Description of a single terminal level I/O switch */

dcl  1 switch_info aligned based (switch_info_ptr),
       2 terminal_iocb_ptr pointer,			/* -> IOCB for terminal level module */
       2 current_physical_record_type fixed binary,	/* type of record currently in buffer (if any) */
       2 current_physical_record_n_els fixed binary (24),	/* # of characters or bits in current record */
       2 current_physical_record_used fixed binary (24),	/* # of characters or bits already returned to caller */
       2 pad bit (36),
       2 tior,					/* terminal_io_record used for I/O */
         3 header like terminal_io_record.header,
         3 data character (IMFT_PHYSICAL_RECORD_LTH) unaligned;

dcl  switch_info_ptr pointer;

/**/

/* Physical record structure used to transmit data and control information */

dcl  1 imft_physical_record aligned based (ipr_ptr),
       2 pad1 bit (2) unaligned,
       2 record_type fixed binary (7) unaligned unsigned,	/* type of record: data or control */
       2 pad2 bit (2) unaligned,
       2 flags unaligned,
         3 binary bit (1) unaligned,			/* ON => binary data in record as 7-bit bytes */
         3 bolr bit (1) unaligned,			/* ON => this is first physical record of a logical record */
         3 eolr bit (1) unaligned,			/* ON => last physical record in logical record */
         3 pad3 bit (4) unaligned,
       2 n_els unaligned,				/* # of elements (characters or 7-bit bytes) */
         3 pad4 bit (2) unaligned,
         3 high_order bit (7) unaligned,
         3 pad5 bit (2) unaligned,
         3 low_order bit (7) unaligned,
       2 data character (IMFT_PHYSICAL_RECORD_DATA_LTH) unaligned;
						/* the actual data */

dcl  1 ipr_data_overlay unaligned based (addr (imft_physical_record.data)),
       2 elements (IMFT_PHYSICAL_RECORD_DATA_LTH) unaligned,/* 7-bit bytes of binary data unpacked in 9 bits */
         3 pad1 bit (2) unaligned,
         3 byte bit (7) unaligned;

dcl  ipr_ptr pointer;

dcl  (
     IMFT_PHYSICAL_RECORD_LTH initial (80),		/* size of each physical record */
     IMFT_PHYSICAL_RECORD_DATA_LTH initial (76),		/* # of bytes of user's data in each record */
     IMFT_PHYSICAL_RECORD_DATA_BITS_LTH initial (532)	/* # of bits of user's data in each record for binary data */
     ) fixed binary static options (constant);

/**/

/* Attach an I/O switch for file transfer */

old_imft_io_attach:
     entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code);

	iocb_ptr = P_iocb_ptr;
	loud_sw = P_loud_sw;
	code = 0;

	iad_ptr = null ();				/* avoid freeing garbage if I/O switch already attached */

	if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_detached;
	     if loud_sw then call com_err_ (P_code, IMFT_IO_, "For switch ^a.", iocb_ptr -> iocb.name);
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup) call cleanup_attachment ((0));


/* Process attachment options */

	if hbound (P_attach_options, 1) < 1 then
	     call abort_attachment (error_table_$noarg,
		"""-direction"", ""-input_description"", and ""-output_description"" must be supplied.");

	allocate iad in (system_area) set (iad_ptr);
	iad.input_switch.terminal_iocb_ptr,		/* keeps cleanup handler happy */
	     iad.output_switch.terminal_iocb_ptr = null ();

	direction = "";				/* haven't seen -direction yet */
	input_description_idx = 0;			/* haven't seen -input_description yet */
	output_description_idx = 0;			/* haven't seen -output_description yet */
	iad.debug_mode = "0"b;			/* haven't seen -debug yet */

	iad.attach_description = "";
	iad.open_description = "";


	do argument_idx = lbound (P_attach_options, 1) to hbound (P_attach_options, 1);

	     argument_ptr = substraddr (P_attach_options (argument_idx), 1);
	     argument_lth = length (P_attach_options (argument_idx));

	     if argument = "-direction" then do;
		direction = get_string_argument ();
		if (direction ^= "input") & (direction ^= "output") then
		     call abort_attachment (error_table_$bad_arg,
			"-direction must be followed by ""input"" or ""output""; not ""^a"".", direction);
	     end;

	     else if (argument = "-input_description") | (argument = "-ids") then do;
		an_attach_description = get_string_argument ();
		input_description_idx = argument_idx;
	     end;

	     else if (argument = "-output_description") | (argument = "-ods") then do;
		an_attach_description = get_string_argument ();
		output_description_idx = argument_idx;
	     end;

	     else if argument = "-debug" then iad.debug_mode = "1"b;

	     else call abort_attachment (error_table_$badopt, """^a""", argument);
	end;

	if direction = "" then call abort_attachment (error_table_$noarg, "-direction");

	if input_description_idx = 0 then call abort_attachment (error_table_$noarg, "-input_description");

	if output_description_idx = 0 then call abort_attachment (error_table_$noarg, "-output_description");


/* Construct our attach description */

	iad.attach_description = rtrim (IMFT_IO_);

	iad.attach_description = iad.attach_description || " -direction ";
	iad.attach_description = iad.attach_description || rtrim (direction);

	argument_ptr = substraddr (P_attach_options (input_description_idx), 1);
	argument_lth = length (P_attach_options (input_description_idx));
	iad.attach_description = iad.attach_description || " -input_description ";
	iad.attach_description = iad.attach_description || requote_string_ (argument);

	argument_ptr = substraddr (P_attach_options (output_description_idx), 1);
	argument_lth = length (P_attach_options (output_description_idx));
	iad.attach_description = iad.attach_description || " -output_description ";
	iad.attach_description = iad.attach_description || requote_string_ (argument);


/* Attach through the terminal level */

	iad.input_direction = (direction = "input");

	terminal_attach_count = terminal_attach_count + 1;
	if terminal_attach_count > 999 then terminal_attach_count = 1;

	terminal_switch_name =
	     rtrim (IMFT_IO_) || ".input." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count));

	call iox_$attach_ioname (terminal_switch_name, terminal_iocb_ptr, (P_attach_options (input_description_idx)),
	     code);
	if code ^= 0 then
	     call abort_attachment (code, "Unable to attach input channel via: ^a",
		P_attach_options (input_description_idx));

	iad.input_switch.terminal_iocb_ptr = terminal_iocb_ptr;


	terminal_switch_name =
	     rtrim (IMFT_IO_) || ".output." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count));

	call iox_$attach_ioname (terminal_switch_name, terminal_iocb_ptr, (P_attach_options (output_description_idx)),
	     code);
	if code ^= 0 then
	     call abort_attachment (code, "Unable to attach output channel via: ^a",
		P_attach_options (output_description_idx));

	iad.output_switch.terminal_iocb_ptr = terminal_iocb_ptr;


/* Initialize the input and output terminal switch structures */

	iad.input_switch.current_physical_record_type, iad.output_switch.current_physical_record_type = -1;
	iad.input_switch.current_physical_record_n_els, iad.output_switch.current_physical_record_n_els = 0;
	iad.input_switch.current_physical_record_used, iad.output_switch.current_physical_record_used = 0;

	iad.input_switch.tior.version, iad.output_switch.tior.version = terminal_io_record_version_1;

	iad.input_switch.tior.device_type = READER_DEVICE;
	iad.output_switch.tior.device_type = PUNCH_DEVICE;

	iad.input_switch.tior.slew_type, iad.output_switch.tior.slew_type = SLEW_BY_COUNT;
	iad.input_switch.tior.slew_count, iad.output_switch.tior.slew_count = 1;

	string (iad.input_switch.tior.flags), string (iad.output_switch.tior.flags) = ""b;

	iad.input_switch.tior.element_size, iad.output_switch.tior.element_size = N_BITS_PER_CHARACTER;
	iad.input_switch.tior.n_elements, iad.output_switch.tior.n_elements = IMFT_PHYSICAL_RECORD_LTH;

	iad.abort_in_progress = "0"b;			/* didn't encounter any errors yet */
	iad.abort_code = 0;


/* Mask and complete construction of the IOCB */

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = addr (iad.attach_description);
	iocb_ptr -> iocb.attach_data_ptr = iad_ptr;
	iocb_ptr -> iocb.open = imft_io_open;
	iocb_ptr -> iocb.detach_iocb = imft_io_detach;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

RETURN_FROM_ATTACH:
	P_code = code;
	return;

/**/

/* Open an I/O switch for file transfer */

imft_io_open:
     entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	open_mode = P_open_mode;

	if ^((iad.input_direction & (open_mode = Stream_input)) | (^iad.input_direction & (open_mode = Stream_output)))
	then do;					/* opening mode and direction must agree */
	     P_code = error_table_$bad_mode;
	     return;
	end;

	call iox_$open (iad.input_switch.terminal_iocb_ptr, Sequential_input, "0"b, P_code);
	if P_code ^= 0 then return;

	call iox_$open (iad.output_switch.terminal_iocb_ptr, Sequential_output, "0"b, P_code);
	if P_code ^= 0 then do;			/* must close the other one to stay happy */
	     call iox_$close (iad.input_switch.terminal_iocb_ptr, (0));
	     return;
	end;

	iad.open_description = rtrim (iox_modes (open_mode));

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	if iad.input_direction then
	     iocb_ptr -> iocb.get_chars, iocb_ptr -> iocb.get_line = imft_io_get_chars;
	else iocb_ptr -> iocb.put_chars = imft_io_put_chars;

	iocb_ptr -> iocb.control = imft_io_control;
	iocb_ptr -> iocb.modes = imft_io_modes;

	iocb_ptr -> iocb.close = imft_io_close;
	iocb_ptr -> iocb.detach_iocb = imft_io_detach;

	iocb_ptr -> iocb.open_descrip_ptr = addr (iad.open_description);
						/* it's now open */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = 0;
	return;

/**/

/* Close an I/O switch used for file transfer */

imft_io_close:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	code = 0;

	if iocb_ptr -> iocb.open_descrip_ptr = null () then do;
	     P_code = error_table_$not_open;
	     return;
	end;

	call iox_$close (iad.output_switch.terminal_iocb_ptr, code);
	if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0;

	call iox_$close (iad.input_switch.terminal_iocb_ptr, code);
	if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0;

	ips_mask = ""b;

	on condition (cleanup) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.open_descrip_ptr = null ();

	iocb_ptr -> iocb.open = imft_io_open;
	iocb_ptr -> iocb.detach_iocb = imft_io_detach;

	iocb_ptr -> iocb.control, iocb_ptr -> iocb.modes, iocb_ptr -> iocb.get_chars, iocb_ptr -> iocb.get_line,
	     iocb_ptr -> iocb.put_chars = iox_$err_no_operation;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = code;

	return;

/**/

/* Detach an I/O switch from file transfer */

imft_io_detach:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr;
	code = 0;

	if iocb_ptr -> iocb.attach_descrip_ptr = null () then do;
	     P_code = error_table_$not_attached;
	     return;
	end;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	call cleanup_attachment (code);

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = null ();	/* it's detached */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = code;				/* in case trouble freeing the channel */
	return;

/**/

/* Write data records to the remote Multics: formats the user's data stream into IMFT physical records and
   transmits them to the remote Multics.  The IMFT physical record format is designed so that one put_chars call on this
   system will be converted into one get_chars (or get_line) call on the remote.  If any errors are detected while
   writing, this I/O module signals the "imft_write_abort_" condition which imft_transmit_object_ handles through the
   "get_abort_info" control order */

imft_io_put_chars:
     entry (P_iocb_ptr, P_data_ptr, P_data_lth, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;
	code = 0;

	if iad.input_direction then do;		/* can't write the input side of a pipe */
	     P_code = error_table_$invalid_write;
	     return;
	end;

	call transmit_logical_data_record (IMFT_DATA, P_data_ptr, P_data_lth);
						/* does the actual work */

	P_code = code;
	return;

/**/

/* Read data records from the remote Multics:  reads requested number of data characters from the remote system.
   Data is read until either the user's buffer is filled or a control record is encountered.  If a control record is read
   before any data is found or an I/O error occurs during a read, the condition "imft_read_abort_" is signalled which is
   recognized by the caller.  The reason for the termination of the read request can be determined by the "get_abort_info"
   control order */

imft_io_get_chars:
     entry (P_iocb_ptr, P_buffer_ptr, P_buffer_max_lth, P_data_lth, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	if ^iad.input_direction then do;		/* attempt to read the "punch" */
	     P_code = error_table_$invalid_read;
	     return;
	end;

	call receive_logical_data_records (P_buffer_ptr, P_buffer_max_lth, P_data_lth);

	P_code = 0;				/* here iff successful */
	return;

/**/

/* Perform control operations on an I/O switch attached for file transfer */

imft_io_control:
     entry (P_iocb_ptr, P_order, P_info_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	iad_ptr = iocb_ptr -> iocb.attach_data_ptr;

	order = P_order;
	info_ptr = P_info_ptr;

	code = 0;


	if order = "write_command_record" then do;

/* Write a command record:  Commands are sent by an output driver to the remote system's input driver to instruct the
   input driver as to what it should do next (begin reception of an object, abort, synchronize, etc.) */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version;

	     else if iad.input_direction then		/* must be transmitting data */
		code = error_table_$invalid_write;

	     else do;
		icri_ptr = info_ptr;
		if icri.timeout > 0 then do;		/* trap no response */
		     call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout);
		     on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
		end;
		call transmit_logical_control_record ((icri.record_type), icri.record_ptr, icri.record_lth, code);
		call timer_manager_$reset_alarm_call (read_write_timeout);
	     end;
	end;


	else if order = "read_command_record" then do;

/* Read a command record: any intervening data records are discarded */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version;

	     else if ^iad.input_direction then		/* must be receiving data to receive control records */
		code = error_table_$invalid_read;

	     else do;
		icri_ptr = info_ptr;
		if icri.timeout > 0 then do;		/* trap no response */
		     call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout);
		     on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
		end;
		call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth,
		     icri.record_type, code);
		call timer_manager_$reset_alarm_call (read_write_timeout);
	     end;
	end;


	else if order = "write_reply_record" then do;

/* Write a reply record:  Reply records are often sent by an input driver in response to a command record and indicate the
   input driver's reasons for accepting or rejecting a command */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version;

	     else if ^iad.input_direction then		/* must be receive side of a connection */
		code = error_table_$invalid_write;

	     else do;
		icri_ptr = info_ptr;
		if icri.timeout > 0 then do;		/* trap no response */
		     call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout);
		     on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
		end;
		call transmit_logical_control_record ((icri.record_type), icri.record_ptr, icri.record_lth, code);
		call timer_manager_$reset_alarm_call (read_write_timeout);
	     end;
	end;


	else if order = "read_reply_record" then do;

/* Read a reply record */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version;

	     else if iad.input_direction then		/* must be transmitting side of connection */
		code = error_table_$invalid_read;

	     else do;
		icri_ptr = info_ptr;
		if icri.timeout > 0 then do;		/* trap no response */
		     call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout);
		     on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
		end;
		call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth,
		     icri.record_type, code);
		call timer_manager_$reset_alarm_call (read_write_timeout);
	     end;
	end;


	else if order = "get_abort_info" then do;

/* Return cause of previous get_chars or put_chars failure */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version;

	     else do;
		icri_ptr = info_ptr;

		if iad.abort_in_progress then do;	/* something did indeed go wrong */
		     iad.abort_in_progress = "0"b;

		     if (iad.abort_code ^= 0) & (iad.abort_code ^= imft_et_$reply_pending) then do;
						/* I/O error during read/write */
			icri.record_type = IMFT_ABORT;
			abort_command_ptr = icri.record_ptr;
			abort_command.reason = IMFT_ABORT_IO_ERROR;
			abort_command.code = iad.abort_code;
			icri.record_lth = 4 * currentsize (abort_command);
		     end;				/* let caller see exact error */

		     else do;			/* encountered a control record: return it */
			call timer_manager_$alarm_call (ONE_MINUTE, RELATIVE_SECONDS, read_write_timeout);
			on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout);
			call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth,
			     icri.record_type, code);
			call timer_manager_$reset_alarm_call (read_write_timeout);
		     end;
		end;

		else code = error_table_$no_operation;	/* no abort was happening */
	     end;
	end;


	else if order = "get_channel_names" then do;

/* Return the names of the channels attached through this switch */

	     if info_ptr = null () then code = error_table_$null_info_ptr;

	     else if info_ptr -> get_channel_names.version ^= GET_CHANNEL_NAMES_VERSION_1 then
		code = error_table_$unimplemented_version;

	     else do;
		get_channel_names_ptr = info_ptr;
		local_tgci.version = tty_get_channel_info_version;

		call iox_$control (iad.input_switch.terminal_iocb_ptr, "get_channel_info", addr (local_tgci), code);

		if code = 0 then do;		/* got the input channel ... */
		     get_channel_names.input_channel = local_tgci.channel_name;
		     call iox_$control (iad.output_switch.terminal_iocb_ptr, "get_channel_info", addr (local_tgci),
			code);
		     if code = 0 then		/* ... and got the output channel */
			get_channel_names.output_channel = local_tgci.channel_name;
		end;

		if code ^= 0 then			/* couldn't get one of the channel names */
		     if code = error_table_$undefined_order_request then code = imft_et_$cant_get_channel_names;
	     end;
	end;


	else if (order = "read_status") | (order = "resetread") then
	     call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code);
						/* always apply these to the input connection */

	else if (order = "write_status") | (order = "resetwrite") | (order = "runout") then
	     call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code);
						/* always apply these to the output connection */

	else if order = "abort" then do;		/* always apply this to both switches */
	     call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code);
	     call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code);
	end;

	else do;					/* pass others on to the appropriate half of the connection */
	     if iad.input_direction then
		call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code);
	     else call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code);
	end;

RETURN_FROM_IMFT_CONTROL:
	P_code = code;

	return;

/**/

/* Internal procedure which is invoked when a read/write of a command/reply record times out */

read_write_timeout:
     procedure ();

	code = imft_et_$timeout;

	if iad.debug_mode then			/* give the programmer a chance when debugging */
	     signal condition (imft_debug_);

	go to RETURN_FROM_IMFT_CONTROL;

     end read_write_timeout;

/**/

/* Change modes: no modes are supported */

imft_io_modes:
     entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	P_old_modes = "";				/* no modes are reflected to caller */

	if P_new_modes = "" then
	     P_code = 0;
	else P_code = error_table_$bad_mode;

	return;

/**/

/* Cleanup whatever portion of an attachment exists */

cleanup_attachment:
     procedure (P_code);

dcl  P_code fixed binary (35) parameter;		/* a parameter to allow callers to ignore it */

	P_code = 0;

	if iad_ptr ^= null () then do;		/* there is an I/O switch */

	     if iad.input_switch.terminal_iocb_ptr ^= null () then do;
		call iox_$close (iad.input_switch.terminal_iocb_ptr, (0));
		call iox_$detach_iocb (iad.input_switch.terminal_iocb_ptr, P_code);
		call iox_$destroy_iocb (iad.input_switch.terminal_iocb_ptr, (0));
		iad.input_switch.terminal_iocb_ptr = null ();
	     end;

	     if iad.output_switch.terminal_iocb_ptr ^= null () then do;
		call iox_$close (iad.output_switch.terminal_iocb_ptr, (0));
		call iox_$detach_iocb (iad.output_switch.terminal_iocb_ptr, P_code);
		call iox_$destroy_iocb (iad.output_switch.terminal_iocb_ptr, (0));
		iad.output_switch.terminal_iocb_ptr = null ();
	     end;

	     free iad in (system_area);
	     iad_ptr = null ();

	end;

	return;

     end cleanup_attachment;

/**/

/* Wrapper to protect against errors while IPS interrupts are masked */

any_other_handler:
     procedure () options (non_quick);

	if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask);
	ips_mask = ""b;

	call continue_to_signal_ ((0));		/* not interested, */

	return;

     end any_other_handler;



/* Abort a call to the attach entry:  print an error message if requested */

abort_attachment:
     procedure () options (variable, non_quick);

dcl  the_code fixed binary (35) based (the_code_ptr);
dcl  the_code_ptr pointer;

dcl  caller_message character (256);

	call cu_$arg_ptr (1, the_code_ptr, (0), (0));

	if loud_sw then do;				/* an error message is requested */
	     call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, (0), "1"b, "0"b);
	     call com_err_ (the_code, IMFT_IO_, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message);
	end;

	call cleanup_attachment ((0));		/* get rid of anything that was accomplished */

	if the_code = 0 then
	     code = error_table_$action_not_performed;
	else code = the_code;			/* save the error code */

	go to RETURN_FROM_ATTACH;

     end abort_attachment;

/**/

/* Fetch the next argument from the attach options and validate that it is a non-null character string */

get_string_argument:
     procedure () returns (character (*));

dcl  option_name character (32);

	option_name = argument;			/* about to move on to the next one */

	if argument_idx = hbound (P_attach_options, 1) then
	     call abort_attachment (error_table_$noarg, "Character string following ""^a"".", option_name);

	argument_idx = argument_idx + 1;

	argument_ptr = substraddr (P_attach_options (argument_idx), 1);
	argument_lth = length (P_attach_options (argument_idx));

	if argument = "" then
	     call abort_attachment (0, "Character string following ""^a"" must be non-null.", option_name);

	return (argument);

     end get_string_argument;

/**/

/* Transmit a logical record to the remote system as multiple physical records */

transmit_logical_record:
     procedure ();

	return;					/* not an entry */


/* Parameters */

dcl  P_logical_record_type fixed binary (7) unaligned unsigned parameter;
						/* type of record being transmitted */
dcl  P_logical_record_data_ptr pointer parameter;		/* -> the logical record */
dcl  P_logical_record_data_lth fixed binary (21) parameter; /* length of logical record in characters */

dcl  P_code fixed binary (35) parameter;		/* control: status code */


/* Remaining declarations */

dcl  logical_record_data character (logical_record_data_lth) unaligned based (logical_record_data_ptr);
dcl  logical_record_data_lth fixed binary (21);
dcl  logical_record_data_ptr pointer;

dcl  logical_record_data_bits bit (logical_record_data_n_bits) unaligned based (logical_record_data_ptr);
dcl  logical_record_data_bits_lth fixed binary (24);

dcl  bytes_array (n_bytes) bit (7) unaligned based (bytes_array_ptr);
dcl  n_bytes fixed binary;
dcl  bytes_array_ptr pointer;

dcl  1 trsi aligned like tty_read_status_info automatic;

dcl  put_chars_operation bit (1) aligned;		/* ON => iox_$put_chars (data records) */

dcl  (amount_sent, amount_left) fixed binary (24);	/* may hold bit counters */
dcl  amount_to_send fixed binary (14);
dcl  fb14uu fixed binary (14) unaligned unsigned;

dcl  based_character character (1) unaligned based;

dcl  idx fixed binary;



/* Transmit a data record: aborts by signalling imft_write_abort_ if an I/O error is encountered */

transmit_logical_data_record:
     entry (P_logical_record_type, P_logical_record_data_ptr, P_logical_record_data_lth);

	put_chars_operation = "1"b;
	go to TRANSMIT_COMMON;


/* Transmit a control record: any errors are reflected to the caller */

transmit_logical_control_record:
     entry (P_logical_record_type, P_logical_record_data_ptr, P_logical_record_data_lth, P_code);

	P_code = 0;
	put_chars_operation = "0"b;


TRANSMIT_COMMON:
	if ^iad.input_direction then do;		/* output side: check for unexpected replies */
	     trsi.input_pending = "0"b;		/* ... in case the next call fails */
	     call iox_$control (iad.input_switch.terminal_iocb_ptr, "read_status", addr (trsi), (0));
	     if trsi.input_pending then call abort_write_operation (imft_et_$reply_pending);
	end;

	logical_record_data_ptr = P_logical_record_data_ptr;
	logical_record_data_lth = P_logical_record_data_lth;

	terminal_io_record_ptr = addr (iad.output_switch.tior);
	ipr_ptr = addr (terminal_io_record.data);

	unspec (imft_physical_record) = ""b;		/* start out clean */

	imft_physical_record.record_type = P_logical_record_type;

	if logical_record_data_lth > 0 then
	     imft_physical_record.binary = (verify (logical_record_data, collate ()) ^= 0);

	amount_sent = 0;


	if logical_record_data_lth = 0 then do;		/* empty record: transmit header only */
	     imft_physical_record.bolr,		/* this is the entire logical record */
		imft_physical_record.eolr = "1"b;
	     call transmit_physical_record ();
	end;


	else if imft_physical_record.binary then do;

/* Binary data: unpack 7 bits at a time into 9 bit forming valid ASCII characters for transmission.  At some future time,
   support for binary transmission should be provided */

	     logical_record_data_bits_lth = N_BITS_PER_CHARACTER * logical_record_data_lth;

	     do while (amount_sent < logical_record_data_bits_lth);

		amount_left = logical_record_data_bits_lth - amount_sent;
		amount_to_send = min (amount_left, IMFT_PHYSICAL_RECORD_DATA_BITS_LTH);
						/* are using 7 bits per character */

		n_bytes = divide (amount_to_send + 6, 7, 17, 0);
		bytes_array_ptr = add_bit_offset_ (logical_record_data_ptr, (amount_sent));
						/* first bit to go into this record */
		do idx = 1 to n_bytes;
		     if idx = n_bytes then		/* special case last byte */
			if mod (amount_to_send, 7) ^= 0 then
			     unspec (substraddr (imft_physical_record.data, (idx)) -> based_character) =
				"00"b || substr (bytes_array (idx), 1, mod (amount_to_send, 7));
			else unspec (substraddr (imft_physical_record.data, (idx)) -> based_character) =
				"00"b || bytes_array (idx);
		     else unspec (substraddr (imft_physical_record.data, (idx)) -> based_character) =
			     "00"b || bytes_array (idx);
		end;

		fb14uu = amount_to_send;		/* record # of bits transmitted */
		imft_physical_record.n_els.high_order = substr (unspec (fb14uu), 1, 7);
		imft_physical_record.n_els.low_order = substr (unspec (fb14uu), 8, 7);

		if amount_sent = 0 then		/* first physical record of logical record */
		     imft_physical_record.bolr = "1"b;
		if amount_to_send = amount_left then	/* last physical record */
		     imft_physical_record.eolr = "1"b;

		call transmit_physical_record ();	/* zap! */

		amount_sent = amount_sent + amount_to_send;
	     end;
	end;


	else do;

/* Character only data */

	     do while (amount_sent < logical_record_data_lth);

		amount_left = logical_record_data_lth - amount_sent;
		amount_to_send = min (amount_left, IMFT_PHYSICAL_RECORD_DATA_LTH);
						/* determine how much to send now */
		imft_physical_record.data = substr (logical_record_data, (amount_sent + 1), amount_to_send);

		fb14uu = amount_to_send;		/* put # of characters in record into the record */
		imft_physical_record.n_els.high_order = substr (unspec (fb14uu), 1, 7);
		imft_physical_record.n_els.low_order = substr (unspec (fb14uu), 8, 7);

		if amount_sent = 0 then		/* first physical record of logical one */
		     imft_physical_record.bolr = "1"b;
		if amount_to_send = amount_left then	/* last physical record */
		     imft_physical_record.eolr = "1"b;

		call transmit_physical_record ();	/* zap! */

		amount_sent = amount_sent + amount_to_send;
	     end;
	end;

	if ^put_chars_operation then			/* here iff all written OK */
	     P_code = 0;

RETURN_FROM_TRANSMIT_LOGICAL_RECORD:
	return;



/* Internal to transmit_logical_record: transmits a single physical record to the remote system */

transmit_physical_record:
	procedure ();

dcl  saved_record_type fixed binary;
dcl  saved_binary_flag bit (1) aligned;
dcl  code fixed binary (35);

	     saved_record_type = imft_physical_record.record_type;
	     saved_binary_flag = imft_physical_record.binary;

	     terminal_io_record.element_size = 9;
	     terminal_io_record.n_elements = IMFT_PHYSICAL_RECORD_LTH;
						/* make sure they're still correct */

	     call iox_$write_record (iad.output_switch.terminal_iocb_ptr, terminal_io_record_ptr,
		(4 * currentsize (terminal_io_record)), code);
	     if code ^= 0 then call abort_write_operation (code);

	     unspec (imft_physical_record) = ""b;	/* start next record clean */
	     imft_physical_record.record_type = saved_record_type;
	     imft_physical_record.binary = saved_binary_flag;

	     return;				/* it won */

	end transmit_physical_record;



/* Internal to transmit_logical_record: aborts the current write operation */

abort_write_operation:
	procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	     if put_chars_operation then do;		/* data stream: abort the operation completely */
		iad.abort_in_progress = "1"b;
		iad.abort_code = p_code;
SIGNAL_TRANSMISSION_FAILURE_FOREVER:
		signal condition (imft_write_abort_);
		go to SIGNAL_TRANSMISSION_FAILURE_FOREVER;
	     end;					/* imft_transmit_object_ shouldn't return */

	     else do;				/* writing a control record: reflect error to caller */
		P_code = p_code;
		go to RETURN_FROM_TRANSMIT_LOGICAL_RECORD;
	     end;

	end abort_write_operation;

     end transmit_logical_record;

/**/

/* Receive the contents of a logical record from the remote system */

receive_logical_record:
     procedure ();

	return;					/* not an entry */

dcl  P_buffer_ptr pointer parameter;			/* -> buffer to place record contents */
dcl  P_buffer_max_lth fixed binary (21) parameter;	/* maximum size of buffer (in characters) */
dcl  P_buffer_used fixed binary (21) parameter;		/* # of characters placed into buffer */

dcl  P_record_type fixed binary parameter;		/* control: set to type of control record found */
dcl  P_code fixed binary (35) parameter;		/* control: status cod */


/* Remaining declarations */

dcl  buffer bit (buffer_max_lth) unaligned based (buffer_ptr);
dcl  (buffer_used, buffer_max_lth) fixed binary (24);
dcl  buffer_ptr pointer;

dcl  buffer_as_chars character (P_buffer_max_lth) unaligned based (buffer_ptr);

dcl  1 byte_structure aligned,
       2 pad bit (2) unaligned,
       2 byte bit (7) unaligned;

dcl  get_chars_operation bit (1) aligned;		/* ON => reading data stream */
dcl  continue bit (1) aligned;

dcl  (space_left, amount_left, amount_to_copy, amount_done) fixed binary (24);
dcl  (characters_used, characters_to_copy) fixed binary (21);
dcl  byte_idx fixed binary (21);
dcl  n_bits_from_byte fixed binary;



/* Receive data records: aborts by signalling imft_read_abort_ if an I/O error is encountered or the previous read
   operation terminated with a control record */

receive_logical_data_records:
     entry (P_buffer_ptr, P_buffer_max_lth, P_buffer_used);

	get_chars_operation = "1"b;
	go to RECEIVE_COMMON;


/* Receive a control record: flushes all data records until a control record is found and returned */

receive_logical_control_record:
     entry (P_buffer_ptr, P_buffer_max_lth, P_buffer_used, P_record_type, P_code);

	P_record_type = -1;				/* haven't found it yet */
	P_code = 0;
	get_chars_operation = "0"b;


RECEIVE_COMMON:
	buffer_ptr = P_buffer_ptr;
	buffer_max_lth = N_BITS_PER_CHARACTER * P_buffer_max_lth;

	buffer_used = 0;

	terminal_io_record_ptr = addr (iad.input_switch.tior);
	ipr_ptr = addr (terminal_io_record.data);


	continue = "1"b;

	do while (continue);

	     if iad.input_switch.current_physical_record_type = -1 then
READ_ANOTHER_RECORD:
		call receive_physical_record ();

	     if iad.input_switch.current_physical_record_type = IMFT_DATA then
		if get_chars_operation then
		     ;				/* data record OK */
		else go to READ_ANOTHER_RECORD;	/* data records should be ignored */

	     else					/* control record ... */
		if get_chars_operation then		/* ... while reading data ... */
		if buffer_used = 0 then		/* ... is only fatal if first read */
		     call abort_read_operation (0);
		else go to END_OF_GET_CHARS;		/* in middle of stream: end of get_chars */

	     if ^get_chars_operation then		/* if reading control records ... */
		if P_record_type = -1 then		/* ... and haven't determined type yet */
		     P_record_type = iad.input_switch.current_physical_record_type;


	     if iad.input_switch.current_physical_record_n_els = 0 then ;
						/* nothing in this record to unpack or copy */


	     else if imft_physical_record.binary then do;

/* Binary data: pack low order 7-bits of each character into the caller's buffer as a continuous bit stream */

		if buffer_used < buffer_max_lth then do;

		     space_left = buffer_max_lth - buffer_used;
		     amount_left =
			iad.input_switch.current_physical_record_n_els
			- iad.input_switch.current_physical_record_used;
		     amount_to_copy = min (space_left, amount_left);

		     amount_done = 0;
		     do while (amount_done < amount_to_copy);
			byte_idx = divide (iad.input_switch.current_physical_record_used, 7, 17, 0) + 1;
			n_bits_from_byte = min ((amount_to_copy - amount_done), 7);
			unspec (byte_structure) = unspec (substr (imft_physical_record.data, byte_idx, 1));
			substr (buffer, (buffer_used + 1), n_bits_from_byte) =
			     substr (byte_structure.byte,
			     (mod (iad.input_switch.current_physical_record_used, 7) + 1), n_bits_from_byte);
			buffer_used = buffer_used + n_bits_from_byte;
			iad.input_switch.current_physical_record_used =
			     iad.input_switch.current_physical_record_used + n_bits_from_byte;
			amount_done = amount_done + n_bits_from_byte;
		     end;
		end;
	     end;


	     else do;

/* Character data: copy it to caller's buffer */

		call adjust_buffer_used ();		/* make sure it's integral # of characters */
		characters_used = divide ((buffer_used + N_BITS_PER_CHARACTER - 1), N_BITS_PER_CHARACTER, 21, 0);

		if buffer_used < buffer_max_lth then do;
		     space_left = buffer_max_lth - buffer_used;
		     amount_left =
			N_BITS_PER_CHARACTER
			* (iad.input_switch.current_physical_record_n_els
			- iad.input_switch.current_physical_record_used);
		     amount_to_copy = min (space_left, amount_left);
		     characters_to_copy =
			divide ((amount_to_copy + N_BITS_PER_CHARACTER - 1), N_BITS_PER_CHARACTER, 21, 0);
		     substr (buffer_as_chars, (characters_used + 1), characters_to_copy) =
			substr (imft_physical_record.data, (iad.input_switch.current_physical_record_used + 1),
			characters_to_copy);
		     buffer_used = buffer_used + amount_to_copy;
		     iad.input_switch.current_physical_record_used =
			iad.input_switch.current_physical_record_used + characters_to_copy;
		end;
	     end;

	     if iad.input_switch.current_physical_record_used >= iad.input_switch.current_physical_record_n_els then
		iad.input_switch.current_physical_record_type = -1;

	     if ^get_chars_operation & imft_physical_record.eolr then continue = "0"b;
						/* got it all */

	     continue = continue & (buffer_used < buffer_max_lth);
	end;

END_OF_GET_CHARS:
	call adjust_buffer_used ();			/* make sure it's integral # of characters */
	P_buffer_used = divide ((buffer_used + N_BITS_PER_CHARACTER - 1), N_BITS_PER_CHARACTER, 21, 0);


RETURN_FROM_RECEIVE_LOGICAL_RECORD:
	return;



/* Internal to receive_logical_record: receives a single physical record */

receive_physical_record:
	procedure ();

dcl  fb14uu fixed binary (14) unaligned unsigned;
dcl  code fixed binary (35);

	     terminal_io_record.element_size = 9;
	     terminal_io_record.n_elements = IMFT_PHYSICAL_RECORD_LTH;

	     call iox_$read_record (iad.input_switch.terminal_iocb_ptr, terminal_io_record_ptr,
		(4 * currentsize (terminal_io_record)), (0), code);
	     if code ^= 0 then call abort_read_operation (code);

	     if terminal_io_record.n_elements ^= IMFT_PHYSICAL_RECORD_LTH then
		call abort_read_operation (error_table_$short_record);

	     iad.input_switch.current_physical_record_type = imft_physical_record.record_type;

	     unspec (fb14uu) = imft_physical_record.n_els.high_order || imft_physical_record.n_els.low_order;
	     iad.input_switch.current_physical_record_n_els = fb14uu;
						/* record # of characters or bytes */

	     iad.input_switch.current_physical_record_used = 0;
						/* haven't taken any */

	     if imft_physical_record.bolr & ^get_chars_operation then
		if buffer_used ^= 0 then		/* missed end of control record */
		     call abort_read_operation (error_table_$improper_data_format);

	     return;

	end receive_physical_record;



/* Internal to receive_logical_record: aborts the current read operation */

abort_read_operation:
	procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	     if get_chars_operation then do;		/* get_chars (data stream): signal imft_read_abort_ */
		iad.abort_in_progress = "1"b;
		iad.abort_code = p_code;
SIGNAL_RECEIVE_FAILURE_FOREVER:
		signal condition (imft_read_abort_);
		go to SIGNAL_RECEIVE_FAILURE_FOREVER;
	     end;

	     else do;				/* reading control record: return code to caller */
		P_code = p_code;
		go to RETURN_FROM_RECEIVE_LOGICAL_RECORD;
	     end;

	end abort_read_operation;



/* Internal to receive_logical_record: adjusts buffer_used to be an integral # of characters */

adjust_buffer_used:
	procedure ();

dcl  n_bits_to_zero fixed binary;

	     if mod (buffer_used, N_BITS_PER_CHARACTER) ^= 0 then do;

		n_bits_to_zero = N_BITS_PER_CHARACTER - mod (buffer_used, N_BITS_PER_CHARACTER);

		substr (buffer, (buffer_used + 1), n_bits_to_zero) = ""b;
						/* insure no garbage in buffer */
		buffer_used = buffer_used + n_bits_to_zero;
	     end;

	     return;

	end adjust_buffer_used;

     end receive_logical_record;

/**/

/* substraddr:  Return a pointer to the specified character of a varying or nonvarying string.  When the substraddr
   builtin function is finally implemented, these internal procedures should be removed */

dcl  substraddr
	generic (substraddr_nonvarying when (character (*) nonvarying, fixed binary precision (1:35)),
	substraddr_varying when (character (*) varying, fixed binary precision (1:35)));


substraddr_nonvarying:
     procedure (P_string, P_position) returns (pointer);

dcl  P_string character (*) nonvarying parameter;
dcl  P_position fixed binary (21) parameter;

dcl  string_overlay (length (P_string)) character (1) unaligned based (addr (P_string));

	return (addr (string_overlay (P_position)));

     end substraddr_nonvarying;


substraddr_varying:
     procedure (P_string, P_position) returns (pointer);

dcl  P_string character (*) varying parameter;
dcl  P_position fixed binary (21) parameter;

dcl  1 string_overlay aligned based (addr (P_string)),
       2 lth fixed binary (21),
       2 characters (0 refer (string_overlay.lth)) character (1) unaligned;

	return (addr (string_overlay.characters (P_position)));

     end substraddr_varying;

/**/

%include iocb;
%page;
%include iox_modes;
%page;
%include terminal_io_record;

%include tty_read_status_info;

%include tty_get_channel_info;
%page;
%include "_imft_cri";

%include "_imft_get_channel_names";
%page;
%include "_imft_std_commands";

     end old_imft_io_;




		    print_imft_sites.pl1            10/28/88  1409.0rew 10/28/88  1232.0       67824



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


/* format: style4 */
print_imft_sites: pis: procedure;

/* This command prints the names of all foreign sites usable with the "-source" or "-destination"
   control argument to the enter_imft_request etc. commands. It does this by
   finding out the names of the request types, and assuming that destinations are
   represented by request type names of the form "To_SITE", and sources by names of
   the form "From_SITE".
*/

/* Written March 1983 by Robert Coren */


/****^  HISTORY COMMENTS:
  1) change(88-08-24,Brunelle), approve(88-08-24,MCR7911),
     audit(88-10-21,Wallman), install(88-10-28,MR12.2-1199):
     Upgraded to version 5 iod tables.  Changed column widths to that needed by
     the longest entry in column.  Added display of comment field.
                                                   END HISTORY COMMENTS */


/* External Procedures & Variables */

dcl  com_err_ entry () options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  error_table_$too_many_args fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  imft_default_rqt_ entry () returns (char (*));
dcl  imft_data_$queue_dirname char (168) external static;
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  pathname_ entry (char (*), char (*)) returns (char (168));

dcl  cleanup condition;
dcl  (addr, after, length, max, null, ptr, rtrim, substr, unspec) builtin;

/* Internal Static */

dcl  IODT_NAME char (32) internal static options (constant) init ("iod_working_tables");
dcl  PRINT_IMFT_SITES char (16) internal static options (constant) init ("print_imft_sites");

/* Automatic */

dcl  access_id_offset fixed bin;			/* offset for ioa_ statement */
dcl  bc fixed bin (24);				/* initiate_file_ bitcount */
dcl  code fixed bin (35);				/* general error code */
dcl  default_site character (32);			/* temp storage for default site name */
dcl  dest_offset fixed bin;				/* offset for ioa_ statement */
dcl  dest_type bit (1);				/* ON if available as destination */
dcl  n_args fixed bin;				/* # of args called with */
dcl  n_sites fixed bin;				/* count of imft sites found in the tables */
dcl  qgt_size fixed bin;				/* # of entries in queue group tables */
dcl  qgtx fixed bin;				/* queue group table index */
dcl  site_name char (32);				/* temp name of the site */
dcl  sitex fixed bin;				/* temp site index */
dcl  source_type bit (1);				/* ON if available as source */

%page;
	call cu_$arg_count (n_args, code);
	if code ^= 0 then do;			/* something wrong -- we're not allowed to be an AF */
	     call com_err_ (code, PRINT_IMFT_SITES);
	     return;
	end;

	if n_args > 0 then do;			/* nor are we supposed to get arguments */
	     call com_err_ (error_table_$too_many_args, PRINT_IMFT_SITES, "^/Usage: print_imft_sites");
	     return;
	end;

	ithp = null ();
	on condition (cleanup) call cleanup_proc;

	call initiate_file_ (imft_data_$queue_dirname, IODT_NAME, R_ACCESS, ithp, bc, code);
	if ithp = null () then do;
	     call com_err_ (code, PRINT_IMFT_SITES, "Could not initiate ^a",
		pathname_ (imft_data_$queue_dirname, IODT_NAME));
	     return;
	end;

	if iod_tables_hdr.version ^= IODT_VERSION_5 then do;
	     call com_err_ (error_table_$unimplemented_version, PRINT_IMFT_SITES,
		"^a is not a proper iod_tables segment.", pathname_ (imft_data_$queue_dirname, IODT_NAME));
	     call cleanup_proc;
	     return;
	end;

	default_site = after (imft_default_rqt_ (), "To_");

	qgtp = ptr (ithp, iod_tables_hdr.q_group_tab_offset);
	qgt_size = q_group_tab.n_q_groups;
%page;
INNER_BLOCK:
	begin;					/* so as to get large enough automatic array for all possible request type names */

dcl  1 site_desc aligned,
       2 max_name_length fixed bin,
       2 max_driver_name_length fixed bin,
       2 max_comment_length fixed bin,
       2 ents (qgt_size) aligned,
         3 name character (32),
         3 driver_name character (32),			/* access name of I/O daemon driver */
         3 flags,
	 4 destination bit (1) unaligned,		/* ON => usable as a destination */
	 4 source bit (1) unaligned,			/* ON => usable as a source */
	 4 default bit (1) unaligned,			/* ON => this is default site */
	 4 pad bit (33) unaligned;

	     n_sites = 0;
	     unspec (site_desc) = "0"b;

	     do qgtx = 1 to qgt_size;
		qgtep = addr (q_group_tab.entries (qgtx));
		if qgte.generic_type = FT_GENERIC_TYPE then
		     if qgte.name ^= FT_GENERIC_TYPE then do; /* name used to indicate default is not interesting */
			if substr (qgte.name, 1, 3) = "To_" then do;
			     site_name = substr (qgte.name, 4);
			     source_type = "0"b;
			     dest_type = "1"b;
			end;

			else if substr (qgte.name, 1, 5) = "From_" then do;
			     site_name = substr (qgte.name, 6);
			     source_type = "1"b;
			     dest_type = "0"b;
			end;

			else do;
			     call com_err_ (0, PRINT_IMFT_SITES,
				"Request type ""^a"" has a generic type of ""^a"" but its name is not of standard form."
				, qgte.name, FT_GENERIC_TYPE);
			     go to NEXT_QGTE;	/* skip it */
			end;

/* now find out if we've already found a request type for this site */

			do sitex = 1 to n_sites while (site_desc (sitex).name ^= site_name);
			end;

			if sitex > n_sites then do;	/* didn't find it */
			     n_sites = sitex;
			     site_desc (sitex).name = site_name;
			     site_desc (sitex).driver_name = qgte.driver_id;
			     if length (rtrim (site_name)) > site_desc.max_name_length then
				site_desc.max_name_length = length (rtrim (site_name));
			     if length (rtrim (qgte.driver_id)) > site_desc.max_driver_name_length then
				site_desc.max_driver_name_length = length (rtrim (qgte.driver_id));
			end;

			if source_type then
			     site_desc (sitex).source = "1"b;

			if dest_type then do;
			     site_desc (sitex).destination = "1"b;
			     if site_name = default_site then
				site_desc (sitex).default = "1"b;
			end;
		     end;
NEXT_QGTE:
	     end;

	     if n_sites = 0 then
		call ioa_ ("No site names found in ^a.", pathname_ (imft_data_$queue_dirname, IODT_NAME));

	     else do;
		call sort_sites;

		access_id_offset = site_desc.max_name_length + 11 + 2;
		dest_offset = site_desc.max_name_length + 11 + 2 + max (9, site_desc.max_driver_name_length) + 2;

		call ioa_ ("Site name^vtAccess ID^vtDest   Source^/",
		     access_id_offset, dest_offset);

		do sitex = 1 to n_sites;
		     call ioa_ ("^a^[ (default)^;^]^vt^a^vt^[  X^;   ^]  ^[    X^;^]",
			site_desc (sitex).name,
			site_desc (sitex).default,
			access_id_offset,
			site_desc (sitex).driver_name,
			dest_offset,
			site_desc (sitex).destination, site_desc (sitex).source);
		end;

	     end;




sort_sites: procedure;

	/*** TO BE SUPPLIED ***/

     end sort_sites;

	end INNER_BLOCK;

	call cleanup_proc;
	return;
%page;
cleanup_proc: procedure;

	if ithp ^= null () then do;
	     call hcs_$terminate_noname (ithp, (0));
	     ithp = null ();
	     return;
	end;
     end cleanup_proc;
%page; %include "_imft_ft_request";
%page; %include access_mode_values;
%page; %include iod_tables_hdr;
%page; %include q_group_tab;
%page; %include queue_msg_hdr;

     end print_imft_sites;



		    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
