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__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=" 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 d