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 driver command */ command: entry (P_source, P_state, P_arglist_ptr, P_code); source = P_source; arglist_ptr = P_arglist_ptr; /* structure containing command arguments */ saved_code = P_code; /* save input code in case command is unknown */ P_code, code = 0; /* claim to handle it */ /* Process the command if recognized */ if (arglist.command = "help") then do; call iodd_msg_ (NORMAL, source, 0, "", "^/** Commands for the IMFT driver **^/"); if static.input_driver then /* an input driver */ call iodd_msg_ (NORMAL, source, 0, "", "receive"); else do; call iodd_msg_ (NORMAL, source, 0, "", "pause_time []"); call iodd_msg_ (NORMAL, source, 0, "", "line_speed"); end; end; else if (arglist.command = "pause_time") | (arglist.command = "pausetime") then do; if static.input_driver then do; /* only for output drivers */ call iodd_msg_ (NORMAL, source, 0, "", "Invalid command for an input driver."); go to COMMAND_ERROR; end; if (arglist.n_tokens > 1) then do; /* a specific time is given */ value = cv_dec_check_ ((arglist.arguments (1)), code); if (code ^= 0) then do; BAD_PAUSE_TIME_SPECIFICATION: call iodd_msg_ (NORMAL, source, error_table_$bad_conversion, "", "Pause time specification must be a number between 0 and 30 seconds; not ""^a"".", arglist.arguments (1)); go to COMMAND_ERROR; end; if (value < 0) | (value > 30) then go to BAD_PAUSE_TIME_SPECIFICATION; static_pause_time = value; /* good value */ end; else static_pause_time = 10; /* reset to default value */ end; else if (arglist.command = "receive") then do; if ^static.input_driver then do; /* only valid for input drivers */ call iodd_msg_ (NORMAL, source, 0, "", "Invalid command for an output driver."); go to COMMAND_ERROR; end; /* Ensure that we are properly attached. */ if ds_ptr -> driver_status.dev_in_iocbp = null () then do; call attach_and_init_line; /* restablish link */ call resynch_and_validate; end; call iodd_msg_ (NORMAL, MASTER, 0, "", "Waiting for ^[files/subtrees^] from ^a.", static.function, static.foreign_system.name); if static.function = FILE_TRANSFER then call imft_receive_object_ (addr (static), addr (static_fis_info), code); if code ^= 0 then do; /* error has already been reported */ call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "Fatal error during ""receive"" command; driver will re-initialize."); signal condition (re_init); end; end; else if (arglist.command = "line_speed") | (arglist.command = "linespeed") then do; if static.input_driver then do; /* only for output drivers */ call iodd_msg_ (NORMAL, source, 0, "", "Invalid command for an input driver."); go to COMMAND_ERROR; end; call iodd_msg_ (NORMAL, source, 0, "", "line_speed = ^i Baud.", ds_ptr -> driver_status.bit_rate_est); end; else code = saved_code; /* unknown request: let caller handle it */ P_code = code; /* pass back any defined errors */ return; COMMAND_ERROR: P_code = error_table_$action_not_performed; /* cause a resetread */ return; %page; /* Handler for unexpected conditions during request processing */ default_handler: entry (P_condition_info_ptr); condition_info_ptr = P_condition_info_ptr; condition = condition_info.condition_name; if iodd_static.request_in_progress then /* will abort the request */ if static.function = FILE_TRANSFER then call imft_transmit_object_$abort_running_request (condition); return; /* should not get here */ %page; /* Synchronize an input driver: Wait for a SYNC1 command from the remote system. When it arrives, validate the ID/password in the command against the foreign ID/password specified locally. If they match, send a SYNC1 reply containing our ID/password to the remote system and wait for a SYNC2 command; otherwise, send a SYNC1 reply explaining the problem and abort. When the SYNC2 command arrives, send a SYNC2 reply if the command indicates that synchronization suceeded; otherwise, abort */ synchronize_input_driver: procedure (); call read_sync_command (IMFT_SYNC1); sync_record_ptr = addr (input_buffer); if static.foreign_system.name ^= sync_record.my_userid then do; call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_ids, IMFT_DRIVER_, "ID specified on local system is ^a; ID specified on remote system is ^a.", static.foreign_system.name, sync_record.my_userid); call write_sync_reply (IMFT_SYNC1, "", "", imft_et_$non_matching_ids, static.foreign_system.name); go to RETURN_FROM_INIT; end; if static.foreign_system.password ^= sync_record.my_password then do; call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_passwords, IMFT_DRIVER_, "Validating foreign system ID. ""^a""", sync_record.my_userid); call write_sync_reply (IMFT_SYNC1, "", "", imft_et_$non_matching_passwords, ""); go to RETURN_FROM_INIT; end; if local_icri.record_lth ^= 4 * currentsize (sync_record) then do; /* remote driver is pre 4.0 */ if foreign_system_version >= 4.0 then do; call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_versions, IMFT_DRIVER_, "Remote system appears to be pre 4.0 but was specified to be ^a on local system.", static.foreign_system.imft_version); call write_sync_reply (IMFT_SYNC1, "", "", imft_et_$non_matching_versions, ""); go to RETURN_FROM_INIT; end; end; else if static.foreign_system.imft_version ^= sync_record.imft_version then do; call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_versions, IMFT_DRIVER_, "Remote system claims to be ""^a"" but specified locally to be ""^a"".", sync_record.imft_version, static.foreign_system.imft_version); call write_sync_reply (IMFT_SYNC1, "", "", imft_et_$non_matching_versions, ""); go to RETURN_FROM_INIT; end; /* Here iff the ID/password in the SYNC1 command were acceptable */ call write_sync_reply (IMFT_SYNC1, static.local_system.name, static.local_system.password, 0, ""); call read_sync_command (IMFT_SYNC2); sync_record_ptr = addr (input_buffer); if sync_record.code = 0 then /* remote system accepted our ID/password */ call write_sync_reply (IMFT_SYNC2, "", "", 0, ""); else do; /* remote output driver didn't like our ID/password */ code = imft_convert_status_code_$decode (sync_record.code); if code = imft_et_$non_matching_ids then call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "ID specified on local system is ^a; ID specified on remote system is ^a.", static.local_system.name, sync_record.correct_userid); else call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Validating local system ID. ""^a""", static.local_system.name); go to RETURN_FROM_INIT; end; return; /* here iff synchronized OK */ %page; /* Internal to synchronize_input_driver: attempts to transmit a SYNC reply */ write_sync_reply: procedure (p_sync_type, p_my_userid, p_my_password, p_code, p_correct_userid); dcl p_sync_type fixed binary (7) unaligned unsigned parameter; dcl (p_my_userid, p_correct_userid) character (*) parameter; dcl p_my_password character (8) aligned parameter; dcl p_code fixed binary (35) parameter; dcl code fixed binary (35); sync_record_ptr = addr (output_buffer); /* need a place to put it */ sync_record.my_userid = p_my_userid; sync_record.my_password = p_my_password; sync_record.code = imft_convert_status_code_$encode (p_code); sync_record.correct_userid = p_correct_userid; sync_record.imft_version = CURRENT_IMFT_VERSION; local_icri.version = ICRI_VERSION_1; local_icri.timeout = FIVE_MINUTES; /* give the other side a chance to respond */ local_icri.record_type = p_sync_type; local_icri.record_ptr = sync_record_ptr; local_icri.record_lth = 4 * currentsize (sync_record); call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "write_reply_record", addr (local_icri), code); if code ^= 0 then do; /* any I/O errors are fatal */ call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to synchronize with ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; end; return; /* success */ end write_sync_reply; /* Internal to synchronize_input_driver: attempts to read a SYNC command */ read_sync_command: procedure (p_sync_type); dcl p_sync_type fixed binary (7) unaligned unsigned parameter; local_icri.version = ICRI_VERSION_1; if static.automatic_operation & (p_sync_type = IMFT_SYNC1) then local_icri.timeout = 0; /* wait forever for start of synchronization sequence */ else local_icri.timeout = FIVE_MINUTES; local_icri.record_ptr = addr (input_buffer); local_icri.record_max_lth = length (input_buffer); call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "read_command_record", addr (local_icri), code); if code = 0 then /* got something ... */ if local_icri.record_type = p_sync_type then return; /* ... got the right type of command */ else do; /* ... anything else causes us to try over again */ call write_sync_reply (IMFT_RESYNCHRONIZE, "", "", 0, ""); go to RESYNCHRONIZE_DRIVER; end; else do; /* some more serious error */ call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to synchronize with ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; end; end read_sync_command; end synchronize_input_driver; %page; /* Establish the AIM access class ceiling for an input driver: Wait for the AIM1 command giving the source system's AIM attributes definition and then transmit an AIM1 reply consisting of our attributes. Wait for the AIM2 command which contains the source system's computed access ceiling and explicit ceiling (if any); verify that they match the local values and that the local explicit ceiling is less than or equal to the computed ceiling. If all goes well, send an AIM2 reply with a zero code; otherwise, send a non-zero reply code and abort */ establish_input_access_ceiling: procedure (); dcl 1 local_aim2_record aligned like aim2_record; call read_aim_command (IMFT_AIM1); /* aborts if we can't get it */ if addr (input_buffer) -> aim_attributes.version ^= AIM_ATTRIBUTES_VERSION_1 then do; call iodd_msg_ (ERROR, MASTER, error_table_$unimplemented_version, IMFT_DRIVER_, "Can not understand AIM definition from ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; /* ... other side will timeout */ end; call free_aim_attributes_storage; allocate aim_attributes in (system_area) set (static.foreign_system.aim_attributes_ptr); static.foreign_system.aim_attributes_ptr -> aim_attributes = addr (input_buffer) -> aim_attributes; call get_system_aim_attributes_ (get_system_free_area_ (), AIM_ATTRIBUTES_VERSION_1, static.local_system.aim_attributes_ptr, code); if code ^= 0 then do; /* shouldn't get this but... */ call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to get local AIM definition."); go to RETURN_FROM_INIT; /* ... other side will timeout */ end; call write_aim_reply (IMFT_AIM1, static.local_system.aim_attributes_ptr, (4 * currentsize (static.local_system.aim_attributes_ptr -> aim_attributes))); /* Have exchanged AIM definitions: wait for AIM2 command and validate other system's computed ceiling and explicit ceiling against our own */ call read_aim_command (IMFT_AIM2); if static.old_version then do; /* we read old, shorter form of AIM2 record */ aim2_record_ptr = addr (local_aim2_record); aim2_record = addr (input_buffer) -> v2_aim2_record, by name; end; else aim2_record_ptr = addr (input_buffer); if aim2_record.code ^= 0 then do; /* remote system couldn't compute definition */ code = imft_convert_status_code_$decode (aim2_record.code); call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; end; call compute_common_aim_ceiling_ (static.local_system.aim_attributes_ptr, static.local_system.access_ceiling, static.foreign_system.aim_attributes_ptr, static.foreign_system.access_ceiling, code); if code ^= 0 then do; CANT_ESTABLISH_CEILING: call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); call write_aim2_reply (code); /* let remote system know we lost */ go to RETURN_FROM_INIT; end; if ^aim_check_$equal (aim2_record.computed_ceiling, static.foreign_system.access_ceiling) then do; call iodd_msg_ (ERROR, MASTER, imft_et_$computed_ceiling_mismatch, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); call write_aim2_reply (imft_et_$computed_ceiling_mismatch); go to RETURN_FROM_INIT; end; if local_explicit_ceiling_given | aim2_record.explicit_ceiling_given then do; if ^local_explicit_ceiling_given then local_explicit_ceiling = static.local_system.access_ceiling; if aim2_record.explicit_ceiling_given then do; call translate_aim_attributes_ (static.foreign_system.aim_attributes_ptr, aim2_record.explicit_ceiling, static.local_system.aim_attributes_ptr, foreign_explicit_ceiling, code); if code ^= 0 then go to CANT_ESTABLISH_CEILING; end; else foreign_explicit_ceiling = static.local_system.access_ceiling; if aim_check_$greater_or_equal (local_explicit_ceiling, foreign_explicit_ceiling) /* other side wants lower ceiling than we had specified */ then static.local_system.access_ceiling = foreign_explicit_ceiling; else if aim_check_$greater (foreign_explicit_ceiling, local_explicit_ceiling) then do; static.local_system.access_ceiling = local_explicit_ceiling; /* our ceiling controls */ call translate_aim_attributes_ (static.local_system.aim_attributes_ptr, static.local_system.access_ceiling, static.foreign_system.aim_attributes_ptr, static.foreign_system.access_ceiling, code); /* so we have to translate it for the other system */ if code ^= 0 then go to CANT_ESTABLISH_CEILING; end; else do; /* neither one is >= the other, so they must be isolated */ call iodd_msg_ (ERROR, MASTER, imft_et_$explicit_ceiling_mismatch, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); call write_aim2_reply (imft_et_$explicit_ceiling_mismatch); go to RETURN_FROM_INIT; end; end; if ^static.old_version then do; if local_explicit_floor_given | aim2_record.explicit_floor_given then do; if ^local_explicit_floor_given then local_explicit_floor = ""b; if aim2_record.explicit_floor_given then do; call translate_aim_attributes_ (static.foreign_system.aim_attributes_ptr, aim2_record.explicit_floor, static.local_system.aim_attributes_ptr, foreign_explicit_floor, code); if code ^= 0 then go to CANT_ESTABLISH_CEILING; end; else foreign_explicit_floor = ""b; if aim_check_$greater_or_equal (foreign_explicit_floor, local_explicit_floor) /* other side wants higher floor than we had specified */ then static.local_system.access_floor = foreign_explicit_floor; else if aim_check_$greater (local_explicit_floor, foreign_explicit_floor) then do; static.local_system.access_floor = local_explicit_floor; /* our floor controls */ call translate_aim_attributes_ (static.local_system.aim_attributes_ptr, static.local_system.access_floor, static.foreign_system.aim_attributes_ptr, static.foreign_system.access_floor, code); /* so we have to translate it for the other system */ if code ^= 0 then go to CANT_ESTABLISH_CEILING; end; else do; /* neither one is >= the other, so they must be isolated */ call iodd_msg_ (ERROR, MASTER, imft_et_$explicit_floor_mismatch, IMFT_DRIVER_, "Attempting to establish access floor with ^a.", static.foreign_system.name); call write_aim2_reply (imft_et_$explicit_floor_mismatch); go to RETURN_FROM_INIT; end; end; else static.local_system.access_floor, static.foreign_system.access_floor = ""b; /* no explicit floors, use system low for both */ if ^aim_check_$greater_or_equal (static.local_system.access_ceiling, static.local_system.access_floor) /* make sure the resulting range is non-null */ then do; call convert_authorization_$to_string_short (static.local_system.access_ceiling, max_access_class_string, code); if code ^= 0 then do; call convert_aim_attributes_ (static.local_system.access_ceiling, max_access_class_octal); max_access_class_string = max_access_class_octal; end; call convert_authorization_$to_string_short (static.local_system.access_floor, min_access_class_string, code); if code ^= 0 then do; call convert_aim_attributes_ (static.local_system.access_floor, min_access_class_octal); min_access_class_string = min_access_class_octal; end; call iodd_msg_ (ERROR, MASTER, error_table_$ai_outside_common_range, IMFT_DRIVER_, "Computed access ceiling (^[^a^;^ssystem_low^]) is not greater than or equal to computed access floor (^[^a^;^ssystem_low^]).", (max_access_class_string ^= ""), max_access_class_string, (min_access_class_string ^= ""), min_access_class_string); call write_aim2_reply (error_table_$ai_outside_common_range); go to RETURN_FROM_INIT; end; end; if ^aim_check_$greater_or_equal (get_authorization_ (), static.local_system.access_ceiling) then do; call convert_authorization_$to_string_short (static.local_system.access_ceiling, max_access_class_string, code); if code ^= 0 then do; call convert_aim_attributes_ (static.local_system.access_ceiling, max_access_class_octal); max_access_class_string = max_access_class_octal; end; call iodd_msg_ (ERROR, MASTER, imft_et_$process_authorization_too_low, IMFT_DRIVER_, "Minimum process authorization must be ^[^a^;^ssystem_low^].", (max_access_class_string ^= ""), max_access_class_string); call write_aim2_reply (imft_et_$process_authorization_too_low); go to RETURN_FROM_INIT; end; /* Here iff AIM ceiling is computed and OK */ call write_aim2_reply (NO_ERROR); return; %page; /* Internal to establish_input_access_ceiling: attempts to transmit an AIM reply */ write_aim_reply: procedure (p_aim_type, p_record_ptr, p_record_lth); dcl p_aim_type fixed binary (7) unaligned unsigned parameter; dcl p_record_ptr pointer parameter; dcl p_record_lth fixed binary (21) parameter; dcl code fixed binary (35); local_icri.version = ICRI_VERSION_1; local_icri.timeout = FIVE_MINUTES; /* give the other side a chance */ local_icri.record_type = p_aim_type; local_icri.record_ptr = p_record_ptr; local_icri.record_lth = p_record_lth; call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "write_reply_record", addr (local_icri), code); if code ^= 0 then do; /* any I/O error is fatal */ call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; end; return; end write_aim_reply; /* Internal to establish_input_access_ceiling: attempts to transmit an AIM2 reply */ write_aim2_reply: procedure (p_code); dcl p_code fixed binary (35) parameter; aim2_record_ptr = addr (output_buffer); /* need a place to put it */ aim2_record.code = imft_convert_status_code_$encode (p_code); if static.old_version then call write_aim_reply (IMFT_AIM2, aim2_record_ptr, (4 * currentsize (v2_aim2_record))); else do; if aim2_record.code = 0 then do; aim2_record.computed_ceiling = static.local_system.access_ceiling; aim2_record.computed_floor = static.local_system.access_floor; end; call write_aim_reply (IMFT_AIM2, aim2_record_ptr, (4 * currentsize (aim2_record))); end; return; end write_aim2_reply; %page; /* Internal to establish_input_access_ceiling: attempts to read an AIM command */ read_aim_command: procedure (p_aim_type); dcl p_aim_type fixed binary (7) unaligned unsigned parameter; local_icri.version = ICRI_VERSION_1; local_icri.timeout = FIVE_MINUTES; /* must be able to read it */ local_icri.record_ptr = addr (input_buffer); local_icri.record_max_lth = length (input_buffer); call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "read_command_record", addr (local_icri), code); if code = 0 then /* got something ... */ if local_icri.record_type = p_aim_type then return; /* ... got the right type of command */ else do; /* ... anything else causes us to try over again */ call write_aim_reply (IMFT_RESYNCHRONIZE, null (), 0); go to RESYNCHRONIZE_DRIVER; end; else do; /* some more serious error */ call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; end; end read_aim_command; end establish_input_access_ceiling; %page; /* Synchronize an output driver: Write a SYNC1 command to the remote input driver with the our system ID and password and wait for a SYNC1 response. On receiving the SYNC1 response, check if the remote system validated that ID/password combination and, if it did, validate the password/ID it sent us against the foreign system ID/password. If the remote input driver's ID/password match, send a SYNC2 command indicating that synchronization is completed; otherwise, send a SYNC2 command explaining the synchronization failure */ synchronize_output_driver: procedure (); call write_sync_command (IMFT_SYNC1, static.local_system.name, static.local_system.password, 0, ""); /* doesn't return on fatal errors */ call read_sync_reply (IMFT_SYNC1); sync_record_ptr = addr (input_buffer); if sync_record.code ^= 0 then do; /* remote input driver didn't like our ID/password */ code = imft_convert_status_code_$decode (sync_record.code); if code = imft_et_$non_matching_ids then call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "ID specified on local system is ^a; ID specified on remote system is ^a.", static.local_system.name, sync_record.correct_userid); else call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Validating local system ID. ""^a""", static.local_system.name); go to RETURN_FROM_INIT; end; if static.foreign_system.name ^= sync_record.my_userid then do; call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_ids, IMFT_DRIVER_, "ID specified on local system is ^a; ID specified on remote system is ^a.", static.foreign_system.name, sync_record.my_userid); call write_sync_command (IMFT_SYNC2, "", "", imft_et_$non_matching_ids, static.foreign_system.name); go to RETURN_FROM_INIT; end; if static.foreign_system.password ^= sync_record.my_password then do; call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_passwords, IMFT_DRIVER_, "Validating foreign system ID. ""^a""", sync_record.my_userid); call write_sync_command (IMFT_SYNC2, "", "", imft_et_$non_matching_passwords, ""); go to RETURN_FROM_INIT; end; if local_icri.record_lth ^= 4 * currentsize (sync_record) then do; /* remote driver is pre 4.0 */ if foreign_system_version >= 4.0 then do; call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_versions, IMFT_DRIVER_, "Remote system appears to be pre 4.0 but was specified to be ^a on local system.", static.foreign_system.imft_version); call write_sync_command (IMFT_SYNC2, "", "", imft_et_$non_matching_versions, ""); go to RETURN_FROM_INIT; end; end; else if static.foreign_system.imft_version ^= sync_record.imft_version then do; call iodd_msg_ (ERROR, MASTER, imft_et_$non_matching_versions, IMFT_DRIVER_, "Remote system claims to be ""^a"" but specified locally to be ""^a"".", sync_record.imft_version, static.foreign_system.imft_version); call write_sync_command (IMFT_SYNC2, "", "", imft_et_$non_matching_versions, ""); go to RETURN_FROM_INIT; end; /* success */ call write_sync_command (IMFT_SYNC2, "", "", 0, ""); call read_sync_reply (IMFT_SYNC2); if sync_record.code ^= 0 then do; call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Completing synchronization sequence."); go to RETURN_FROM_INIT; end; return; /* here iff synchronized OK */ %page; /* Internal to syncrhonize_output_driver: attempts to transmit a SYNC command */ write_sync_command: procedure (p_sync_type, p_my_userid, p_my_password, p_code, p_correct_userid); dcl p_sync_type fixed binary (7) unaligned unsigned parameter; dcl (p_my_userid, p_correct_userid) character (*) parameter; dcl p_my_password character (8) aligned parameter; dcl p_code fixed binary (35) parameter; dcl code fixed binary (35); sync_record_ptr = addr (output_buffer); /* need a place to put it */ sync_record.my_userid = p_my_userid; sync_record.my_password = p_my_password; sync_record.code = imft_convert_status_code_$encode (p_code); sync_record.correct_userid = p_correct_userid; sync_record.imft_version = CURRENT_IMFT_VERSION; local_icri.version = ICRI_VERSION_1; local_icri.timeout = FIVE_MINUTES; /* give the other side a chance to respond */ local_icri.record_type = p_sync_type; local_icri.record_ptr = sync_record_ptr; local_icri.record_lth = 4 * currentsize (sync_record); call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "write_command_record", addr (local_icri), code); if code = 0 then return; /* success */ else if code = imft_et_$reply_pending then /* there's a reply to be checked out first ... */ /* ... must be other side asking us to start over */ call read_sync_reply (IMFT_RESYNCHRONIZE); else do; /* some more serious error */ call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to synchronize with ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; end; end write_sync_command; /* Internal to synchronize_output_driver: attempts to read a SYNC reply */ read_sync_reply: procedure (p_sync_type); dcl p_sync_type fixed binary (7) unaligned unsigned parameter; local_icri.version = ICRI_VERSION_1; if static.automatic_operation & (p_sync_type = IMFT_SYNC1) then local_icri.timeout = 0; /* wait forever for start of synchronization sequence */ else local_icri.timeout = FIVE_MINUTES; local_icri.record_ptr = addr (input_buffer); local_icri.record_max_lth = length (input_buffer); call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "read_reply_record", addr (local_icri), code); if code = 0 then /* got something ... */ if local_icri.record_type = IMFT_RESYNCHRONIZE then go to RESYNCHRONIZE_DRIVER; /* ... remote system wants us to start over */ else if (p_sync_type = 0) | (local_icri.record_type = p_sync_type) then return; /* ... got the right type of reply or will take any reply */ else do; /* ... anything else is residue from a now dead driver */ call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "Unexpected reply code ^d from ^a; driver will attempt to resyncrhonize.", local_icri.record_type, static.foreign_system.name); go to RESYNCHRONIZE_DRIVER; end; else do; /* some more serious error */ call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to synchronize with ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; end; end read_sync_reply; end synchronize_output_driver; %page; /* Establish the AIM access class ceiling for an output driver: Send an AIM1 command giving our system's AIM attributes definition and wait for the remote system to send an AIM1 reply with its AIM definition. When we have both definitions, compute the common access ceiling (if possible), validate our explicit ceiling (if any) which must be less than the computed ceiling and, if all is OK, send an AIM2 command. When the AIM2 response is received, check for the remote system requesting termination */ establish_output_access_ceiling: procedure (); /* We will allocate storage for attributes, ensure any old stuff is freed. */ call free_aim_attributes_storage; call get_system_aim_attributes_ (get_system_free_area_ (), AIM_ATTRIBUTES_VERSION_1, static.local_system.aim_attributes_ptr, code); if code ^= 0 then do; /* shouldn't get this but... */ call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to get local AIM definition."); go to RETURN_FROM_INIT; /* ... other side will timeout */ end; call write_aim_command (IMFT_AIM1, static.local_system.aim_attributes_ptr, (4 * currentsize (static.local_system.aim_attributes_ptr -> aim_attributes))); call read_aim_reply (IMFT_AIM1); /* aborts if we can't get it */ if addr (input_buffer) -> aim_attributes.version ^= AIM_ATTRIBUTES_VERSION_1 then do; call iodd_msg_ (ERROR, MASTER, error_table_$unimplemented_version, IMFT_DRIVER_, "Can not understand AIM definition from ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; /* ... other side will timeout */ end; allocate aim_attributes in (system_area) set (static.foreign_system.aim_attributes_ptr); static.foreign_system.aim_attributes_ptr -> aim_attributes = addr (input_buffer) -> aim_attributes; /* Have exchanged AIM definitions: compute common access class ceiling, validate our explicit ceiling (if any), and send the AIM2 command */ call compute_common_aim_ceiling_ (static.local_system.aim_attributes_ptr, static.local_system.access_ceiling, static.foreign_system.aim_attributes_ptr, static.foreign_system.access_ceiling, code); if code ^= 0 then do; CANT_ESTABLISH_CEILING: call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); call write_aim2_command (code); /* let remote system know we lost */ go to RETURN_FROM_INIT; end; if local_explicit_ceiling_given then /* check explicit ceiling */ if aim_check_$greater_or_equal (static.local_system.access_ceiling, local_explicit_ceiling) then do; call translate_aim_attributes_ (static.local_system.aim_attributes_ptr, local_explicit_ceiling, static.foreign_system.aim_attributes_ptr, foreign_explicit_ceiling, code); if code ^= 0 then go to CANT_ESTABLISH_CEILING; if ^aim_check_$greater_or_equal (get_authorization_ (), local_explicit_ceiling) then do; call convert_authorization_$to_string_short (local_explicit_ceiling, max_access_class_string, code); if code ^= 0 then do; call convert_aim_attributes_ (local_explicit_ceiling, max_access_class_octal); max_access_class_string = max_access_class_octal; end; call iodd_msg_ (ERROR, MASTER, imft_et_$process_authorization_too_low, IMFT_DRIVER_, "Minimum process authorization must be ^[^a^;^ssystem_low^].", (max_access_class_string ^= ""), max_access_class_string); call write_aim2_command (imft_et_$process_authorization_too_low); go to RETURN_FROM_INIT; end; end; else do; /* explicit ceiling is out of range */ call iodd_msg_ (ERROR, MASTER, error_table_$ai_outside_common_range, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); call write_aim2_command (error_table_$ai_outside_common_range); go to RETURN_FROM_INIT; end; else do; /* not changing the ceiling: check driver's authoriztion */ if ^aim_check_$greater_or_equal (get_authorization_ (), static.local_system.access_ceiling) then do; call convert_authorization_$to_string_short (static.local_system.access_ceiling, max_access_class_string, code); if code ^= 0 then do; call convert_aim_attributes_ (static.local_system.access_ceiling, max_access_class_octal); max_access_class_string = max_access_class_octal; end; call iodd_msg_ (ERROR, MASTER, imft_et_$process_authorization_too_low, IMFT_DRIVER_, "Minimum process authorization must be ^[^a^;^ssystem_low^].", (max_access_class_string ^= ""), max_access_class_string); call write_aim2_command (imft_et_$process_authorization_too_low); go to RETURN_FROM_INIT; end; end; if ^static.old_version then do; if local_explicit_floor_given then do; if ^aim_check_$greater_or_equal (static.local_system.access_ceiling, local_explicit_floor) then do; /* floor is not below common ceiling, we can't run */ call iodd_msg_ (ERROR, MASTER, error_table_$ai_outside_common_range, "Common access ceiling is not greater than or equal to minimum access class."); call write_aim2_command (error_table_$ai_outside_common_range); go to RETURN_FROM_INIT; end; static.local_system.access_floor = local_explicit_floor; end; else static.local_system.access_floor = ""b; /* use system_low */ end; call write_aim2_command (NO_ERROR); /* we're happy */ /* Wait for AIM2 reply and abort if foreign system requests it */ call read_aim_reply (IMFT_AIM2); aim2_record_ptr = addr (input_buffer); if aim2_record.code ^= 0 then do; /* remote system couldn't compute definition */ code = imft_convert_status_code_$decode (aim2_record.code); call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; end; if static.old_version then if local_explicit_ceiling_given then do; /* OK: now set the true ceilings */ static.local_system.access_ceiling = local_explicit_ceiling; static.foreign_system.access_ceiling = foreign_explicit_ceiling; end; else ; else do; /* real agreed-on ceiling and floor are in AIM2 reply record */ call translate_aim_attributes_ (static.foreign_system.aim_attributes_ptr, aim2_record.computed_ceiling, static.local_system.aim_attributes_ptr, static.local_system.access_ceiling, code); if code ^= 0 then do; call iodd_msg_ (ERROR, MASTER, code, "Translating final access ceiling."); go to RETURN_FROM_INIT; /* no way to tell other system */ end; static.foreign_system.access_ceiling = aim2_record.computed_ceiling; call translate_aim_attributes_ (static.foreign_system.aim_attributes_ptr, aim2_record.computed_floor, static.local_system.aim_attributes_ptr, static.local_system.access_floor, code); if code ^= 0 then do; call iodd_msg_ (ERROR, MASTER, code, "Translating final access floor."); go to RETURN_FROM_INIT; /* no way to tell other system */ end; static.foreign_system.access_floor = aim2_record.computed_floor; end; return; %page; /* Internal to establish_output_access_ceiling: attempts to transmit an AIM command */ write_aim_command: procedure (p_aim_type, p_record_ptr, p_record_lth); dcl p_aim_type fixed binary (7) unaligned unsigned parameter; dcl p_record_ptr pointer parameter; dcl p_record_lth fixed binary (21) parameter; dcl code fixed binary (35); local_icri.version = ICRI_VERSION_1; local_icri.timeout = FIVE_MINUTES; /* give the other side a chance */ local_icri.record_type = p_aim_type; local_icri.record_ptr = p_record_ptr; local_icri.record_lth = p_record_lth; call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "write_command_record", addr (local_icri), code); if code = 0 then return; /* success */ else if code = imft_et_$reply_pending then /* there's a reply to be checked out first ... */ /* ... must be other side asking us to start over */ call read_aim_reply (IMFT_RESYNCHRONIZE); else do; /* some more serious error */ call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; end; return; end write_aim_command; /* Internal to establish_output_access_ceiling: attempts to transmit an AIM2 command */ write_aim2_command: procedure (p_code); dcl p_code fixed binary (35) parameter; dcl record_size fixed binary (21); aim2_record_ptr = addr (output_buffer); /* need a place to put it */ aim2_record.code = imft_convert_status_code_$encode (p_code); if static.old_version then do; v2_aim2_record.computed_ceiling = static.local_system.access_ceiling; v2_aim2_record.explicit_ceiling_given = local_explicit_ceiling_given; v2_aim2_record.explicit_ceiling = local_explicit_ceiling; record_size = 4 * currentsize (v2_aim2_record); end; else do; aim2_record.computed_ceiling = static.local_system.access_ceiling; aim2_record.explicit_ceiling_given = local_explicit_ceiling_given; aim2_record.explicit_ceiling = local_explicit_ceiling; aim2_record.computed_floor = static.local_system.access_floor; aim2_record.explicit_floor_given = local_explicit_floor_given; aim2_record.explicit_floor = local_explicit_floor; record_size = 4 * currentsize (aim2_record); end; call write_aim_command (IMFT_AIM2, aim2_record_ptr, record_size); return; end write_aim2_command; %page; /* Internal to establish_output_access_ceiling: attempts to read an AIM reply */ read_aim_reply: procedure (p_aim_type); dcl p_aim_type fixed binary (7) unaligned unsigned parameter; local_icri.version = ICRI_VERSION_1; local_icri.timeout = FIVE_MINUTES; /* must be able to read it */ local_icri.record_ptr = addr (input_buffer); local_icri.record_max_lth = length (input_buffer); call iox_$control (ds_ptr -> driver_status.dev_in_iocbp, "read_reply_record", addr (local_icri), code); if code = 0 then /* got something ... */ if local_icri.record_type = IMFT_RESYNCHRONIZE then go to RESYNCHRONIZE_DRIVER; /* ... remote system wants us to start over */ else if local_icri.record_type = p_aim_type then return; /* ... got the right type of reply */ else do; /* ... anything else is residue from a now dead driver */ call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "Unexpected reply code ^d from ^a; driver will atempt to resynchronize.", local_icri.record_type, static.foreign_system.name); go to RESYNCHRONIZE_DRIVER; end; else do; /* some more serious error */ call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attempting to establish access ceiling with ^a.", static.foreign_system.name); go to RETURN_FROM_INIT; end; end read_aim_reply; end establish_output_access_ceiling; %page; /* Check for remote input driver termination: This procedure is called every iodd_static.wakeup_time seconds while an output driver is idle. It checks to see if the remote system has sent a reply requesting resynchronization or logout of the local output driver */ check_for_resync_request: procedure (); /* If we are a dial sender, and we are supposed to drop the line to conserve network costs when the driver goes idle, then drop it here and signal the dial receiver that we are going away for a while. We will pick up and reconnect the line in the request processing when we see that the iocbp is null. */ if static.idle_line_drop = "1"b then do; /* Determine if we are to idle the line yet. Each time the coord sends us a daemon idle, we increment this counter. When we have seen enough then we will idle the line. The prevents rapid line drops and raises. */ static.idle_delay = static.idle_delay + 1; if static.idle_delay <= static.idle_delay_count then goto delay_idle_down; /* wait a bit */ if ds_ptr -> driver_status.dev_out_iocbp = null then goto idled; iodd_static.re_init_in_progress = "1"b; /* re-initialize the driver */ iodd_static.slave.log_msg = "1"b; /* send to log and slave */ call iodd_msg_ (LOG, BOTH, 0, "", "^a ^a ^[input^;output^] driver going to sleep at ^a.", static.foreign_system.name, FUNCTION_NAMES (static.function), static.input_driver, date_time_$format ("date_time", clock (), "", "")); local_icri.record_type = IMFT_LOGOUT; local_icri.version = ICRI_VERSION_1; local_icri.timeout = 15; /* ... doesn't really have to get through */ local_icri.record_ptr = null (); /* ... no associated data */ local_icri.record_lth, local_icri.record_max_lth = 0; if ds_ptr -> driver_status.dev_out_iocbp ^= null () then do; call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "write_command_record", addr (local_icri), ignore_code); end; call iox_$control (iodd_static.slave_out, "runout", null (), ignore_code); call drop_device (); idled: call continue_to_signal_ (ignore_code); return; end; delay_idle_down: call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "read_status", addr (trsi), code); if code ^= 0 then do; COULD_NOT_RAISE_REMOTE: call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Fatal error while checking status of remote input driver; driver will re-initialize."); signal condition (re_init); end; if trsi.input_pending then do; /* see what's going on */ local_icri.version = ICRI_VERSION_1; local_icri.timeout = FIVE_MINUTES; /* in case the remote input driver is sick */ local_icri.record_ptr = addr (input_buffer); /* need to put is someplace */ local_icri.record_max_lth = length (input_buffer); call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "read_reply_record", addr (local_icri), code); if code ^= 0 then go to COULD_NOT_RAISE_REMOTE; if local_icri.record_type = IMFT_RESYNCHRONIZE then signal condition (imft_resynchronize_driver_); else if local_icri.record_type = IMFT_LOGOUT then signal condition (imft_remote_logout_); else do; /* some unexpected event */ call iodd_msg_ (NORMAL, MASTER, 0, IMFT_DRIVER_, "Unexpected reply code ^d from ^a; driver will re-initialize.", local_icri.record_type, static.foreign_system.name); signal condition (re_init); end; end; call continue_to_signal_ (ignore_code); return; end check_for_resync_request; %page; /* Free allocated storage if it exists. */ free_aim_attributes_storage: proc; /* aim attributes occupy allocated storage. We need to free it prior to allocating new stuff. Otherwise we end up cluttering area.linker. */ if static.foreign_system.aim_attributes_ptr ^= null () then free static.foreign_system.aim_attributes_ptr -> aim_attributes; static.foreign_system.aim_attributes_ptr = null (); if static.local_system.aim_attributes_ptr ^= null () then free static.local_system.aim_attributes_ptr -> aim_attributes; static.local_system.aim_attributes_ptr = null (); end free_aim_attributes_storage; %page; /* Drop the device and hang it up */ drop_device: procedure (); dcl send_hangup bit (1) aligned; dcl iocb_ptr ptr; send_hangup = "1"b; go to DROP_DEVICE_COMMON; /* Drop the device only */ detach_device: entry (); if static.dial_service then send_hangup = "1"b; else send_hangup = "0"b; DROP_DEVICE_COMMON: iodd_static.attach_name = "*"; ds_ptr -> driver_status.attached = "0"b; iocb_ptr = ds_ptr -> driver_status.dev_out_iocbp; ds_ptr -> driver_status.dev_out_iocbp, ds_ptr -> driver_status.dev_in_iocbp = null (); /* Kill any possible associated minor device. */ if iodd_static.assigned_devices = 2 then do; /* copy necessary stuff to second minor */ /* device's status structure */ devp = iodd_static.driver_list_ptr -> driver_ptr_list.stat_segp (2); devp -> driver_status.attached = "0"b; devp -> driver_status.ready = "0"b; devp -> driver_status.dev_out_iocbp = ds_ptr -> driver_status.dev_out_iocbp; devp -> driver_status.dev_in_iocbp = ds_ptr -> driver_status.dev_in_iocbp; end; iodd_static.attach_name = "*"; call close_and_detach (iocb_ptr, send_hangup); /* If we were an in-dial then we have to drop the dial service and kill the event channel too. */ if static.in_dial_qualifier ^= "" & dma.dial_channel ^= 0 then do; call ipc_$decl_ev_wait_chn (dma.dial_channel, code); call dial_manager_$shutoff_dials (addr (dma), code); call ipc_$drain_chn (dma.dial_channel, code); call ipc_$delete_ev_chn (dma.dial_channel, code); dma.dial_channel = 0; end; call continue_to_signal_ (ignore_code); /* in case this is called from a handler */ return; end drop_device; %page; /* Close and detach the line to the remote system */ close_and_detach: procedure (P_iocb_ptr, P_send_hangup); dcl P_iocb_ptr pointer parameter; dcl P_send_hangup bit (1) aligned; if P_iocb_ptr = null () then return; /* may be used before anything's attached */ if P_send_hangup then do; /* caller requested a hangup of the line */ if static.in_dial_qualifier ^= "" then /* ignore hangups */ call ipc_$decl_ev_call_chn (dma.dial_channel, nulle, null (), 1, code); else do; hangup_info.entry = nulle; /* ... prevent the hangup from causing a reinit */ hangup_info.data_ptr = null (); hangup_info.priority = 20; call iox_$control (P_iocb_ptr, "hangup_proc", addr (hangup_info), ignore_code); end; /* Wait for any line runout to arrive at the target before dropping the line */ call timer_manager_$sleep (FIVE_SECONDS, RELATIVE_SECONDS); call iox_$control (P_iocb_ptr, "hangup", null (), ignore_code); end; call iox_$close (P_iocb_ptr, ignore_code); call iox_$detach_iocb (P_iocb_ptr, ignore_code); call iox_$destroy_iocb (P_iocb_ptr, ignore_code); return; end close_and_detach; /* May be invoked when a hangup occurs */ nulle: procedure (); return; end nulle; %page; /* Attach the line to the remote system */ attach_line: procedure (); dcl attach_description character (512) varying; dcl character_line character (local_icri.record_lth) unaligned based (local_icri.record_ptr); dcl code fixed bin (35); dcl error_message char (64); dcl io_module char (32); dcl no_dialed fixed bin; dcl open_mode fixed binary; dcl previous_attach_code fixed bin (35); dcl prev_proto_error bit (1); dcl sleep_time fixed bin (71); dcl which_channel char (32); %skip (5); /* Attach a line with the target system. Two forms of attachment are possible: 1. argument described attachment. This attachment takes the attach description from the iod_tables or the args file. It describes the io module and the line information. 2. in-dial described attachment. This attachment takes the attach description from the dial_manager information returned when a dial-up for the dial-name occurs. This permits attach_line to determine the io module and line information. Attachment can be a simple line attachment, or can include a protocol data handshake. Error processing is such that only the first occurance of a particular error is noted in the log, and then error retrying occurs. This holds for line attachment, opening and protocol handshake. If a line error occurs, the device is dropped and a re-attachment, opening and handshake is done. This ensures a clean line attachment. */ /* If line was previously attached we will drop the device here and try again. */ if ds_ptr -> driver_status.dev_out_iocbp ^= null () then call drop_device; /* Ensure we are clean */ previous_attach_code = 0; prev_proto_error = "0"b; /* no handshake error outstanding */ retry_attach: sleep_time = FIVE_MINUTES; /* default wait */ /* If we are an in_dial, then setup the dial channel and wait for a connection. When a connection has occurred, we determine the io module name, etc., and continue as if a suitable args input had been given to us. */ on cleanup call drop_device; /* we drop unattached */ if static.in_dial_qualifier ^= "" then do; call ipc_$create_ev_chn (dma.dial_channel, code); if code ^= 0 then do; error_message = "couldn't create an event channel"; goto IN_DIAL_ERROR; end; dma.version = 1; dma.dial_qualifier = rtrim (static.in_dial_qualifier); call dial_manager_$allow_dials (addr (dma), code); if code ^= 0 then do; error_message = "error from dial_manager_$allow_dials call"; IN_DIAL_ERROR: call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Creating dial channel ^a for ^[input^;output^] driver to ^a ^a: ^a.", static.in_dial_qualifier, static.input_driver, static.foreign_system.name, FUNCTION_NAMES (static.function), error_message) ; goto RETURN_FROM_INIT; end; event_wait_channel.channel_id = dma.dial_channel; call ipc_$block (addr (event_wait_channel), addr (ev_wait_info), code); /* We now have a connection. Determine information about it, and formulate the correct value for static.input_attach_description from the io_module name and the line name. */ call convert_dial_message_$return_io_module (ev_wait_info.message, which_channel, io_module, no_dialed, status_flags, code); if code ^= 0 then do; error_message = "couldn't convert the dial message"; goto IN_DIAL_ERROR; end; if ^status_flags.dialed_up then do; error_message = "have a connection but channel is not dialed up"; goto IN_DIAL_ERROR; end; static.input_attach_description = rtrim (io_module) || " " || rtrim (which_channel); call iodd_msg_ (NORMAL, MASTER, 0, "", "Dial Channel ^a connected from ^a.", static.input_attach_description, static.foreign_system.name); end; %page; /* Complete connection by attaching the line. We have to determine the information and connect a dial-out channel. */ if static.old_version then attach_description = "old_imft_io_ -direction "; else attach_description = "imft_io_ -direction "; if static.input_driver then do; attach_description = attach_description || " input "; open_mode = Stream_input; end; else do; attach_description = attach_description || " output "; open_mode = Stream_output; end; if static.single_switch then do; attach_description = attach_description || " -io_description "; attach_description = attach_description || requote_string_ (rtrim (static.input_attach_description)); end; else do; attach_description = attach_description || " -input_description "; attach_description = attach_description || requote_string_ (rtrim (static.input_attach_description)); attach_description = attach_description || " -output_description "; attach_description = attach_description || requote_string_ (rtrim (static.output_attach_description)); end; if static.debug_mode then attach_description = attach_description || " -debug"; if static.copy_data then attach_description = attach_description || " -copy_data"; ds_ptr -> driver_status.dev_out_stream = get_switch_name (); call iox_$attach_ioname ((ds_ptr -> driver_status.dev_out_stream), ds_ptr -> driver_status.dev_out_iocbp, (attach_description), code); ds_ptr -> driver_status.dev_in_iocbp = ds_ptr -> driver_status.dev_out_iocbp; if code ^= 0 then go to ACTION_ERROR; call iox_$open (ds_ptr -> driver_status.dev_out_iocbp, open_mode, "0"b, code); if code ^= 0 then go to ACTION_ERROR; else previous_attach_code = 0; /* Start the line going if we have attached an in-dial line. */ if static.in_dial_qualifier ^= "" then call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "start", null (), code); if static.out_dial_text = "" then call set_hangup_proc (); /* enable handling of hangups */ call get_data_channel_names (); /* determine names of channels forming the connection */ /* Connection Protocol handshake. */ if static.in_dial_qualifier ^= "" then call put_chars ("IMFT TRANSPORT ESTABLISHED "); if static.out_dial_text = "" then return; /* normal connection */ %page; /* Handle connection protocol necessary for line attachment to a remote system. This consists of waiting for the trigger_text, then emitting the dial_text and completing the protocol. */ call ipc_$decl_ev_call_chn (dma.dial_channel, /* ignore hangups */ protocol_hangup, stat_p, 1, code); call wait_for_trigger (rtrim (static.trigger_text)); /* emit the dial text, and validate the dial connection */ call put_chars (rtrim (static.out_dial_text) || NL); call get_line (); if index (character_line, " dialed to ") = 0 then do; hangup_protocol: if ^prev_proto_error then call iodd_msg_ (NORMAL, MASTER, 0, IMFT_DRIVER_, "Protocol error - received ""^a""^/driver will retry every ^i minute^[s^;^].", character_line, static.sleep_time, static.sleep_time > 1); sleep_time = static.sleep_time * ONE_MINUTE; prev_proto_error = "1"b; goto ACTION_RETRY; end; call wait_for_trigger ("IMFT TRANSPORT ESTABLISHED "); call set_hangup_proc; return; /* Action errors are processed here for line errors, such as attach and open. If error codes are the same as before then no message is emitted and a silent retry is performed after a 5 minute wait. */ ACTION_ERROR: if ^static.automatic_operation | code ^= previous_attach_code then call iodd_msg_ (ERROR, MASTER, code, IMFT_DRIVER_, "Attaching line for ^a ^a ^[input^;output^] driver^/^-attach description: ^a", static.foreign_system.name, FUNCTION_NAMES (static.function), static.input_driver, attach_description) ; prev_proto_error = "0"b; /* no prev error */ /* Entry here is from the protocol error. We want to handle the normal automatic_operation actions and retry the attach and handshake again. */ ACTION_RETRY: if static.automatic_operation /* keep trying every 5 minutes, so operator */ /* doesn't have to do anything */ then do; previous_attach_code = code; call drop_device; call timer_manager_$sleep (sleep_time, RELATIVE_SECONDS); goto retry_attach; end; else go to RETURN_FROM_INIT; /* NO RETRY */ /* dummy procedure to handle line hangup during protocol handshaking. */ protocol_hangup: proc; goto hangup_protocol; end protocol_hangup; /* Internal to attach_line: put and get characters at the transport level. */ put_chars: procedure (characters); dcl characters character (*) parameter; local_icri.version = ICRI_VERSION_1; local_icri.timeout = FIVE_MINUTES; local_icri.record_ptr = addr (characters); local_icri.record_lth = length (characters); local_icri.record_max_lth = length (characters); call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "put_transport_chars", addr (local_icri), code); if code ^= 0 then goto hangup_protocol; if static.debug_connect then call iodd_msg_ (NORMAL, MASTER, 0, "", "S-""^a""", rtrim (characters, " ")); return; end; get_line: procedure (); local_icri.version = ICRI_VERSION_1; local_icri.timeout = FIVE_MINUTES; local_icri.record_ptr = addr (character_buffer); local_icri.record_lth = 0; local_icri.record_max_lth = length (character_buffer); call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "get_transport_line", addr (local_icri), code); if code ^= 0 then goto hangup_protocol; if static.debug_connect then call iodd_msg_ (NORMAL, MASTER, 0, "", "R-""^a""", rtrim (character_line, " ")); return; end; /* Wait for a protocol triggering string to be received. */ wait_for_trigger: proc (string); dcl string char (*); do trigger_loop_count = 1 to MAX_TRIGGER_LOOP_COUNT; call get_line; if index (character_line, string) ^= 0 then return; /* got it! */ end; /* didn't get satisfactory response from other end */ call iodd_msg_ (ERROR, MASTER, error_table_$fatal_error, IMFT_DRIVER_, "Dial-out protocol retry limit reached, attaching line for ^a ^a ^[input^;output^] driver^/^-attach description: ^a", static.foreign_system.name, FUNCTION_NAMES (static.function), static.input_driver, attach_description) ; go to hangup_protocol; end wait_for_trigger; /* Internal to attach_line: determine the name for the I/O switch */ get_switch_name: procedure () returns (character (32)); attachment_count = attachment_count + 1; if attachment_count > 999 then /* avoid conversion errors */ attachment_count = 1; if static.input_driver then return ("input." || ltrim (convert (attachment_count_pic, attachment_count))); else return ("output." || ltrim (convert (attachment_count_pic, attachment_count))); end get_switch_name; /* Internal to attach_line: set the device hangup procedure for the line */ set_hangup_proc: procedure (); if static.in_dial_qualifier ^= "" then call ipc_$decl_ev_call_chn (dma.dial_channel, iodd_hangup_, stat_p, 1, code); else do; hangup_info.entry = iodd_hangup_; hangup_info.data_ptr = stat_p; hangup_info.priority = 1; call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "hangup_proc", addr (hangup_info), code); end; if code ^= 0 then call iodd_msg_ (NORMAL, MASTER, code, IMFT_DRIVER_, "Warning: Could not establish handler for disconnection from ^a.", static.foreign_system.name); return; end set_hangup_proc; /* Internal to attach_line: determine the names of the channels connected used for data transmission. These are used in various messages to notify logs as to the lines attached for input and output. We fill in the iodd_static.attach_name variable to enable the status request response to indicate what line is currently attached. Cleanup code is necessary to restore the "*" string to this variable outside the driver and any time the line is unattached. */ get_data_channel_names: procedure (); have_channel_names = "0"b; /* assume failure */ local_gcn.version = GET_CHANNEL_NAMES_VERSION_1; call iox_$control (ds_ptr -> driver_status.dev_out_iocbp, "get_channel_names", addr (local_gcn), code); if code = 0 then do; have_channel_names = "1"b; if static.input_driver then iodd_static.attach_name = local_gcn.input_channel; else iodd_static.attach_name = local_gcn.output_channel; end; else if code ^= imft_et_$cant_get_channel_names then call iodd_msg_ (NORMAL, MASTER, code, IMFT_DRIVER_, "Warning: Could not determine channel names for ^a ^a ^[input^;output^] driver.", static.foreign_system.name, FUNCTION_NAMES (static.function), static.input_driver); return; end get_data_channel_names; end attach_line; %page; /* Make sure request type name is valid in form and corresponds to foreign system name */ validate_request_type: procedure (devp); dcl devp pointer parameter; dcl req_type_site character (32); if substr (devp -> driver_status.req_type_label, 1, 3) = "To_" then req_type_site = substr (before (devp -> driver_status.req_type_label, "."), 4); else if substr (devp -> driver_status.req_type_label, 1, 5) = "From_" then req_type_site = substr (before (devp -> driver_status.req_type_label, "."), 6); else do; call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "request type ""^a"" is not in correct format.", devp -> driver_status.req_type_label); go to RETURN_FROM_INIT; end; if req_type_site ^= static.foreign_system.name then do; call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "Request type (^a) does not correspond to foreign system (^a).", devp -> driver_status.req_type_label, static.foreign_system.name); go to RETURN_FROM_INIT; end; end validate_request_type; %page; /* Validates that a value is either "yes" or "no" and returns true or false accordingly */ yes_no_p: procedure (P_keyword, P_value) returns (bit (1) aligned); dcl (P_keyword, P_value) character (*) parameter; if P_value = "y" then P_value = "yes"; if P_value = "n" then P_value = "no"; if (P_value ^= "yes") & (P_value ^= "no") then do; call iodd_msg_ (ERROR, MASTER, 0, IMFT_DRIVER_, "The value of the ""^a"" keyword must be ""yes"" or ""no""; not ""^a"".", P_keyword, P_value); go to RETURN_FROM_INIT; end; return (P_value = "yes"); end yes_no_p; %page; /* Parameters */ dcl P_stat_p pointer parameter; /* init: -> iodd_static for this driver */ dcl P_source fixed binary parameter; /* command: source of the command (master/slave) */ dcl P_state fixed binary parameter; /* command: current state of driver (normal/quit/request) */ dcl P_arglist_ptr pointer parameter; /* command: -> structure defining command and arguments */ dcl P_code fixed binary (35) parameter; /* command: status code */ dcl P_condition_info_ptr pointer parameter; /* default_handler: -> description of the condition */ /* Remaining declarations */ dcl major_args character (major_args_lth) unaligned based (major_args_ptr); dcl major_args_lth fixed binary (21); dcl major_args_ptr pointer; dcl major_args_path character (204) static; /* need room for archive component */ dcl major_args_dirname character (168) static; dcl (major_args_ename, major_args_component) character (32) static; dcl major_args_bc fixed binary (24) static; dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer static; dcl 1 arglist aligned based (arglist_ptr), /* structure defining a command and it's arguments */ 2 max_tokens fixed binary, /* # of tokens allocated */ 2 n_tokens fixed binary, /* # of tokens in command line */ 2 command character (64) varying, 2 arguments (arglist.n_tokens - 1) character (64) varying; dcl arglist_ptr pointer; dcl 1 local_terminal_info aligned like terminal_info automatic; dcl 1 trsi aligned like tty_read_status_info; dcl 1 event_channel_list aligned based, /* list of event channels associated with driver */ 2 n_channels fixed binary, 2 channels (12) fixed binary (71); dcl 1 hangup_info aligned, /* for "hangup_proc" control order */ 2 entry entry () variable, 2 data_ptr pointer, 2 priority fixed binary; dcl 1 local_icri aligned like icri static; /* for synchronization */ dcl 1 local_gcn aligned like get_channel_names static; /* to get input/output channel names */ dcl have_channel_names bit (1) aligned static; dcl 1 dma like dial_manager_arg static; dcl 1 ev_wait_info static like event_wait_info; dcl 1 status_flags aligned static, ( 2 dialed_up bit (1), 2 hung_up bit (1), 2 control bit (1), 2 pad bit (33) ) unal; dcl ds_ptr pointer static; /* -> driver_status for this driver */ dcl devp pointer static; /* -> driver_status for a minor device */ dcl rd_ptr pointer static; /* -> request_descriptor of current request */ dcl p pointer; dcl i fixed binary; dcl max_access_class_string character (256) static; dcl max_access_class_octal character (32) aligned static; dcl min_access_class_string character (256) static; dcl min_access_class_octal character (32) aligned static; dcl (local_explicit_ceiling, foreign_explicit_ceiling) bit (72) aligned static; dcl (local_explicit_floor, foreign_explicit_floor) bit (72) aligned static; dcl (local_explicit_ceiling_given, local_explicit_floor_given) bit (1) aligned static; dcl foreign_system_version float binary static; dcl keyword_value character (32) static; dcl (code, ignore_code, saved_code) fixed binary (35) static; dcl my_ring fixed binary (3); dcl test_initiate_entry entry () variable; dcl character_buffer character (256) static; /* for transport connection protocol */ dcl temp_attach_description character (256) static; dcl trigger_loop_count fixed bin static; dcl source fixed binary static; /* source of the command being processed */ dcl value fixed binary (35) static; dcl condition character (32) static; dcl (input_buffer, output_buffer) character (2048) static; /* for reading/writing commands/replies */ dcl (saved_test_entry, send_logout_record) bit (1) aligned static; dcl 1 static aligned like imft_driver_info static; /* complete description of this driver */ dcl 1 static_fis_info aligned like fis_info static; /* used by imft_find_input_switch_ */ dcl static_pause_time fixed binary (71) static; /* # of seconds to pause between requests */ dcl attachment_count fixed binary static initial (0); dcl attachment_count_pic picture "999" static; dcl IMFT_DRIVER_ character (32) static options (constant) initial ("imft_driver_"); dcl CURRENT_IMFT_VERSION character (3) static options (constant) initial ("4.0"); dcl FIVE_MINUTES fixed binary static options (constant) initial (300); dcl FIVE_SECONDS fixed binary (71) static options (constant) initial (5); dcl MAX_TRIGGER_LOOP_COUNT fixed binary static options (constant) initial (20); dcl NO_ERROR fixed binary (35) static options (constant) initial (0); dcl ONE_MINUTE fixed binary static options (constant) initial (60); dcl NL character (1) static options (constant) initial (" "); dcl WHITESPACE character (5) static options (constant) initial (" "); /* SP HT NL VT FF */ dcl INITIAL_IMFT_RATE fixed binary static options (constant) initial (4800); dcl LISTEN_COMMAND_LEVEL fixed binary static options (constant) initial (1); /* command entered from iodd_listen_ with a ready device */ dcl ( error_table_$ai_outside_common_range, error_table_$action_not_performed, error_table_$bad_conversion, error_table_$fatal_error, error_table_$inconsistent, error_table_$noarg, error_table_$unimplemented_version ) fixed binary (35) external; dcl ( imft_et_$cant_get_channel_names, imft_et_$computed_ceiling_mismatch, imft_et_$explicit_ceiling_mismatch, imft_et_$explicit_floor_mismatch, imft_et_$non_matching_ids, imft_et_$non_matching_passwords, imft_et_$non_matching_versions, imft_et_$process_authorization_too_low, imft_et_$reply_pending ) fixed binary (35) external; dcl add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl compute_common_aim_ceiling_ entry (pointer, bit (72) aligned, pointer, bit (72) aligned, fixed binary (35)); dcl continue_to_signal_ entry (fixed binary (35)); dcl convert_aim_attributes_ entry (bit (72) aligned, character (32) aligned); dcl convert_authorization_$from_string entry (bit (72) aligned, character (*), fixed binary (35)); dcl convert_authorization_$to_string_short entry (bit (72) aligned, character (*), fixed binary (35)); dcl convert_dial_message_$return_io_module entry (fixed bin (71), char (*), char (*), fixed bin, 1 aligned, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, 2 bit (33) unal, fixed bin (35)); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl dial_manager_$allow_dials entry (ptr, fixed bin (35)); dcl dial_manager_$shutoff_dials entry (ptr, fixed bin (35)); dcl expand_pathname_$component entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl get_authorization_ entry () returns (bit (72) aligned); dcl get_ring_ entry () returns (fixed bin (3)); dcl get_system_aim_attributes_ entry (pointer, character (8), pointer, fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl imft_convert_status_code_$decode entry (fixed binary (35)) returns (fixed binary (35)); dcl imft_convert_status_code_$encode entry (fixed binary (35)) returns (fixed binary (35)); dcl imft_pnt_interface_$get_system_password entry (character (*), character (8) aligned, fixed binary (35)); dcl imft_receive_object_ entry (pointer, pointer, fixed binary (35)); dcl imft_transmit_object_ entry (pointer, pointer, pointer, fixed binary (35)); dcl imft_transmit_object_$abort_running_request entry (character (*)); dcl initiate_file_$component entry (character (*), character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl iodd_command_processor_ entry (fixed binary, fixed binary, character (*), fixed binary (35)); dcl iodd_hangup_ entry (ptr); dcl iodd_listen_ entry (pointer); dcl iodd_msg_ entry () options (variable); dcl iodd_parse_$args entry (char (*) var, char (*)) returns (char (256) var); dcl iodd_quit_handler_ entry (); dcl iodd_quit_handler_$command_level entry (); dcl iox_$attach_ioname entry (character (*), pointer, character (*), fixed binary (35)); dcl iox_$close entry (pointer, fixed binary (35)); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl iox_$detach_iocb entry (pointer, fixed binary (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35)); dcl ipc_$decl_ev_wait_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); dcl pathname_$component entry (character (*), character (*), character (*)) returns (character (194)); dcl requote_string_ entry (character (*)) returns (character (*)); dcl system_privilege_$initiate entry (); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); dcl timer_manager_$sleep entry (fixed binary (71), bit (2)); dcl translate_aim_attributes_ entry (pointer, bit (72) aligned, pointer, bit (72) aligned, fixed binary (35)); dcl (cleanup, daemon_idle, daemon_logout, daemon_new_device, daemon_slave_logout, linkage_error, imft_debug_, imft_remote_logout_, imft_resynchronize_driver_, no_coord, quit, re_init, resume) condition; dcl (addr, before, clock, convert, currentsize, divide, index, length, ltrim, null, rtrim, substr) builtin; %page; %include access_mode_values; %page; %include aim_attributes; %page; %include condition_info; %page; %include dial_manager_arg; %page; %include driver_ptr_list; %page; %include driver_status; %page; %include event_wait_channel; %include event_wait_info; %page; %include "_imft_cri"; %page; %include "_imft_driver_info"; %page; %include "_imft_fis_info"; %page; %include "_imft_ft_request"; %page; %include "_imft_get_channel_names"; %page; %include "_imft_std_commands"; %page; %include iod_constants; %page; %include iod_tables_hdr; %page; %include iodd_msg_constants; %page; %include iodd_static; %page; %include iox_modes; %page; %include mseg_message_info; %page; %include queue_msg_hdr; %page; %include request_descriptor; %page; %include set_term_type_info; %include terminal_info; %page; %include terminate_file; %page; %include timer_manager_constants; %page; %include tty_read_status_info; end imft_driver_;  imft_et_.alm 10/14/88 1248.7rew 10/14/88 1212.6 21186 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1988 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " Error table for the Inter-Multics File Transfer Facility " Created: April 1982 by G. Palter " Modified: July 1982 by G. Palter for true AIM support " HISTORY COMMENTS: " 1) change(88-07-11,Beattie), approve(88-08-01,MCR7948), " audit(88-10-11,Farley), install(88-10-14,MR12.2-1165): " Add entry for mismatching versions. " END HISTORY COMMENTS name imft_et_ include et_macros et imft_et_ ec cant_access_pnt,nopnt, (IMFT driver process can not access the system PNT.) ec cant_get_channel_names,nochnnms, (IMFT driver can not determine the names of the channels used for data transmission.) ec computed_ceiling_mismatch,^eqcc, (Local and remote systems did not compute the same access class ceiling.) ec explicit_ceiling_mismatch,^eqec, (max_access_class specified on local and remote systems are isolated.) ec explicit_floor_mismatch,^eqef, (min_access_class specified on local and remote systems are isolated.) ec no_card_password,^pass, (Person_id specified does not have a card input password.) ec no_person_id,^id, (Person_id specified does not exist.) ec non_matching_ids,^mtchids, (Person_ids on local and remote systems do not match.) ec non_matching_passwords,^mtchpas, (Card input passwords on local and remote systems do not match.) ec non_matching_versions,^mtchvrs, (Remote system IMFT version does not match specification on local system.) ec not_synchronized,^sync, (Remote system is not sychronized with local system.) ec process_authorization_too_low,palow, (Maximum access class for data transfer is greater than process authorization.) ec reply_pending,rpypndg, (Reply to previous command pending.) ec timeout,timeout, (Attempt to read/write record timed out.) ec unknown_status_code,badcode, (Status code from remote system is not recognized by this driver.) end  imft_find_input_switch_.pl1 08/08/88 1543.2r w 08/08/88 1408.8 26244 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* Searches a list of I/O switches for the first one for which input is available: if there is no input, optionally block until some becomes available */ /* Created: April 1982 by G. Palter */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ imft_find_input_switch_: procedure (P_fis_info_ptr, P_block, P_switch, P_code); /* Parameters */ dcl P_fis_info_ptr pointer parameter; /* -> the list of switche s */ dcl P_block bit (1) aligned parameter; /* ON => block if no input available */ dcl P_switch fixed binary parameter; /* set to index of switch with input (if any) */ dcl P_code fixed binary (35) parameter; /* Remaining declarations */ dcl 1 rsi aligned like tty_read_status_info; dcl 1 ewi aligned like event_wait_info; dcl idx fixed binary; dcl error_table_$bad_arg fixed binary (35) external; dcl error_table_$unimplemented_version fixed binary (35) external; dcl convert_ipc_code_ entry (fixed binary (35)); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl ipc_$block entry (pointer, pointer, fixed binary (35)); dcl addr builtin; /* */ fis_info_ptr = P_fis_info_ptr; if fis_info.version ^= FIS_INFO_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if fis_info.n_iocbs ^= fis_info.n_channels then do; P_code = error_table_$bad_arg; return; end; /* Check the list for a switch with available input */ CHECK_FOR_INPUT: rsi.input_pending = "0"b; /* some I/O modules don't clear this */ do idx = 1 to fis_info.n_iocbs; call iox_$control (fis_info.iocbs (idx), "read_status", addr (rsi), P_code); if P_code ^= 0 then return; /* can't check all the switches */ if rsi.input_pending then do; /* found it */ P_switch = idx; return; /* ... code already zero from above call */ end; end; if ^P_block then do; /* don't wait around */ P_switch = 0; /* ... none found */ return; /* ... code already zeroed by last call above */ end; /* Block until some input is available: after the wakeup it is necessary to check all the switches again as the I/O modules send wakeups under various conditions (input available, channel hungup, etc.) */ call ipc_$block (addr (fis_info.wait_list), addr (ewi), P_code); if P_code ^= 0 then do; /* block failed */ call convert_ipc_code_ (P_code); return; end; go to CHECK_FOR_INPUT; /* look again */ /* */ %include "_imft_fis_info"; %page; %include event_wait_info; %include tty_read_status_info; end imft_find_input_switch_;  imft_hasp_.pl1 07/19/83 1226.8r w 07/19/83 1018.3 234585 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* I/O module to translate between IMFT logical records and HASP physical records */ /* Created: January 1983 by Robert Coren using Gary Palter's hasp-only imft_io_ as a base */ /* Modified: June 1983 by Robert Coren to requote attach options when building attach description */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ imft_hasp_: procedure (); return; /* not an entry */ /* Parameters */ dcl P_iocb_ptr pointer parameter; /* *: -> I/O switch being operated upon */ dcl P_code fixed binary (35) parameter; dcl P_attach_options (*) character (*) varying parameter; /* attach: attachment arguments */ dcl P_loud_sw bit (1) parameter; /* attach: ON => attachment errors should call com_err_ */ dcl P_open_mode fixed binary parameter; /* open: opening mode */ dcl P_open_sw bit (1) parameter; /* open: obsolete parameter */ dcl P_record_length fixed binary (21) parameter; /* read_record: set to # of characters read into buffer; write_record: # of characters to transmit as logical record */ dcl P_buffer_ptr pointer parameter; /* read_record: -> area to place result of read */ dcl P_buffer_max_lth fixed binary (21) parameter; /* read_record: size of area in characters */ dcl P_record_ptr pointer parameter; /* write_record: -> record to be written */ dcl P_order character (*) parameter; /* control: name of control order to be performed */ dcl P_info_ptr pointer parameter; /* control: -> additional information required to execute the control order */ dcl P_new_modes character (*) parameter; /* modes: new modes to be set */ dcl P_old_modes character (*) parameter; /* modes: set to modes in effect before change */ /* Local copies of parameters */ dcl iocb_ptr pointer; dcl code fixed binary (35); dcl loud_sw bit (1) aligned; dcl open_mode fixed binary; /* Remaining declarations */ dcl system_area area aligned based (system_area_ptr); dcl system_area_ptr pointer; dcl arg_index fixed binary; /* # of attach option being processed */ dcl terminal_attach_desc character (512); dcl terminal_switch_name character (32); dcl module_type character (12); /* "host_" or "workstation_" */ dcl data_received fixed bin (21); dcl packed_length fixed bin (21); dcl unpacked_chars fixed bin (21); dcl logical_record_data character (logical_record_data_lth) unaligned based (logical_record_data_ptr); dcl logical_record_data_lth fixed binary (21); dcl logical_record_data_ptr pointer; dcl logical_record_data_bits_lth fixed binary (24); dcl amount_left fixed binary (21); dcl amount_sent fixed binary (24); /* may hold bit counters */ dcl amount_to_send fixed binary (21); dcl fb14uu fixed binary (14) unaligned unsigned; dcl data_bytes char (n_bytes) based; dcl n_bytes fixed bin (21); dcl ips_mask bit (36); dcl IMFT_HASP_ character (32) static options (constant) initial ("imft_hasp_"); dcl N_BITS_PER_CHARACTER fixed binary static options (constant) initial (9); /* format: off */ dcl (error_table_$action_not_performed, error_table_$bad_mode, error_table_$eof_record, error_table_$improper_data_format, error_table_$long_record, error_table_$not_attached, error_table_$not_closed, error_table_$not_detached, error_table_$not_open, error_table_$short_record, error_table_$unimplemented_version) fixed binary (35) external; /* format: on */ dcl com_err_ entry () options (variable); dcl continue_to_signal_ entry (fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$reset_ips_mask entry (bit (36), bit (36)); dcl hcs_$set_ips_mask entry (bit (36), bit (36)); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1)); dcl iox_$attach_ioname entry (character (*), pointer, character (*), fixed binary (35)); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl iox_$close entry (pointer, fixed binary (35)); dcl iox_$destroy_iocb entry (pointer, fixed binary (35)); dcl iox_$detach_iocb entry (pointer, fixed binary (35)); dcl iox_$err_no_operation entry () options (variable); dcl iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35)); dcl iox_$propagate entry (pointer); dcl iox_$read_record entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl iox_$write_record entry (pointer, pointer, fixed binary (21), fixed binary (35)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl (any_other, cleanup) condition; dcl (addbitno, addcharno, addr, bin, bit, currentsize, divide, hbound, index, lbound, length, min, mod, null, rtrim, size, string, substr, unspec) builtin; /* */ /* Description of a switch attached through this module */ dcl 1 iad aligned based (iad_ptr), 2 attach_description character (1024) varying, /* attach description for this I/O switch */ 2 open_description character (24) varying, /* open description for this I/O switch */ 2 switch like switch_info, /* defines the terminal switch */ 2 flags aligned, 3 input_direction bit (1) unaligned, /* ON => receives data from remote system */ 3 pad bit (35) unaligned; dcl iad_ptr pointer; /* Description of a single terminal level I/O switch */ dcl 1 switch_info aligned based, 2 terminal_iocb_ptr pointer, /* -> IOCB for terminal level module */ 2 current_physical_record_type fixed binary, /* type of record currently in buffer (if any) */ 2 current_physical_record_n_els fixed binary (24), /* # of characters or bits in current record */ 2 current_physical_record_used fixed binary (24), /* # of characters or bits already returned to caller */ 2 pad bit (36), 2 tior, /* terminal_io_record used for I/O */ 3 header like terminal_io_record.header, 3 data character (IMFT_PHYSICAL_RECORD_LTH) unaligned; /* */ /* Physical record structure used to transmit data and control information */ dcl 1 imft_physical_record aligned based (ipr_ptr), 2 pad1 bit (11) unaligned, 2 flags unaligned, 3 binary bit (1) unaligned, /* ON => binary data in record as 7-bit bytes */ 3 bolr bit (1) unaligned, /* ON => this is first physical record of a logical record */ 3 eolr bit (1) unaligned, /* ON => last physical record in logical record */ 3 pad3 bit (4) unaligned, 2 n_els unaligned, /* # of elements (characters or 7-bit bytes) */ 3 pad4 bit (2) unaligned, 3 high_order bit (7) unaligned, 3 pad5 bit (2) unaligned, 3 low_order bit (7) unaligned, 2 data character (IMFT_PHYSICAL_RECORD_DATA_LTH) unaligned; /* the actual data */ dcl ipr_ptr pointer; dcl ( IMFT_PHYSICAL_RECORD_LTH initial (180), /* size of each physical record */ IMFT_PHYSICAL_RECORD_DATA_LTH initial (176), /* # of bytes of user's data in each record */ IMFT_PHYSICAL_RECORD_DATA_BITS_LTH initial (1232) /* # of bits of user's data in each record for binary data */ ) fixed binary static options (constant); /* */ /* Attach an I/O switch for file transfer */ imft_hasp_host_attach: entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code); module_type = "host_"; go to ATTACH_COMMON; imft_hasp_workstation_attach: entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code); module_type = "workstation_"; ATTACH_COMMON: iocb_ptr = P_iocb_ptr; loud_sw = P_loud_sw; code = 0; iad_ptr = null (); /* avoid freeing garbage if I/O switch already attached */ if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do; P_code = error_table_$not_detached; if loud_sw then call com_err_ (P_code, IMFT_HASP_, "For switch ^a.", iocb_ptr -> iocb.name); return; end; system_area_ptr = get_system_free_area_ (); on condition (cleanup) call cleanup_attachment ((0)); allocate iad in (system_area) set (iad_ptr); iad.switch.terminal_iocb_ptr = null (); /* keeps cleanup handler happy */ iad.attach_description = ""; iad.open_description = ""; do arg_index = lbound (P_attach_options, 1) to hbound (P_attach_options, 1); iad.attach_description = iad.attach_description || " " || requote_string_ ((P_attach_options (arg_index))); end; if index (iocb_ptr -> iocb.name, ".input.") ^= 0 then iad.input_direction = "1"b; else if index (iocb_ptr -> iocb.name, ".output.") ^= 0 then iad.input_direction = "0"b; else call abort_attachment (0, "Swtich name ^a does not specify input or output", iocb_ptr -> iocb.name); terminal_switch_name = "hasp_" || substr (module_type, 1, 1) || "." || rtrim (iocb_ptr -> iocb.name); terminal_attach_desc = "hasp_" || rtrim (module_type) || iad.attach_description; /* note that iad.attach_description already has leading space */ call iox_$attach_ioname (terminal_switch_name, iad.switch.terminal_iocb_ptr, terminal_attach_desc, code); if code ^= 0 then call abort_attachment (code, "Unable to attach channel via: ^a", terminal_attach_desc); /* Initialize the terminal switch structure */ iad.switch.current_physical_record_type = -1; iad.switch.current_physical_record_n_els = 0; iad.switch.current_physical_record_used = 0; iad.switch.tior.version = terminal_io_record_version_1; if module_type = "workstation_" then do; if iad.input_direction then iad.switch.tior.device_type = READER_DEVICE; else iad.switch.tior.device_type = PUNCH_DEVICE; end; else do; if iad.input_direction then iad.switch.tior.device_type = PUNCH_DEVICE; else iad.switch.tior.device_type = READER_DEVICE; end; iad.switch.tior.slew_type = SLEW_BY_COUNT; iad.switch.tior.slew_count = 1; string (iad.switch.tior.flags) = ""b; iad.switch.tior.element_size = N_BITS_PER_CHARACTER; iad.switch.tior.n_elements = IMFT_PHYSICAL_RECORD_LTH; /* Mask and complete construction of the IOCB */ ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = addr (iad.attach_description); iocb_ptr -> iocb.attach_data_ptr = iad_ptr; iocb_ptr -> iocb.open = imft_hasp_open; iocb_ptr -> iocb.detach_iocb = imft_hasp_detach; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); RETURN_FROM_ATTACH: P_code = code; return; /* */ /* Open an I/O switch for file transfer */ imft_hasp_open: entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; open_mode = P_open_mode; if ^((iad.input_direction & (open_mode = Sequential_input)) | (^iad.input_direction & (open_mode = Sequential_output))) then do; /* opening mode and direction must agree */ P_code = error_table_$bad_mode; return; end; call iox_$open (iad.switch.terminal_iocb_ptr, open_mode, "0"b, P_code); if P_code ^= 0 then return; iad.open_description = rtrim (iox_modes (open_mode)); ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); if iad.input_direction then iocb_ptr -> iocb.read_record = imft_hasp_read_record; else iocb_ptr -> iocb.write_record = imft_hasp_write_record; iocb_ptr -> iocb.control = imft_hasp_control; iocb_ptr -> iocb.modes = imft_hasp_modes; iocb_ptr -> iocb.close = imft_hasp_close; iocb_ptr -> iocb.detach_iocb = imft_hasp_detach; iocb_ptr -> iocb.open_descrip_ptr = addr (iad.open_description); /* it's now open */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = 0; return; /* */ /* Close an I/O switch used for file transfer */ imft_hasp_close: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; code = 0; if iocb_ptr -> iocb.open_descrip_ptr = null () then do; P_code = error_table_$not_open; return; end; call iox_$close (iad.switch.terminal_iocb_ptr, code); if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0; ips_mask = ""b; on condition (cleanup) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.open_descrip_ptr = null (); iocb_ptr -> iocb.open = imft_hasp_open; iocb_ptr -> iocb.detach_iocb = imft_hasp_detach; iocb_ptr -> iocb.control, iocb_ptr -> iocb.modes, iocb_ptr -> iocb.read_record, iocb_ptr -> iocb.write_record = iox_$err_no_operation; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = code; return; /* */ /* Detach an I/O switch from file transfer */ imft_hasp_detach: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr; code = 0; if iocb_ptr -> iocb.attach_descrip_ptr = null () then do; P_code = error_table_$not_attached; return; end; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; system_area_ptr = get_system_free_area_ (); iad_ptr = iocb_ptr -> iocb.attach_data_ptr; call cleanup_attachment (code); ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = null (); /* it's detached */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = code; /* in case trouble freeing the channel */ return; /* */ /* Perform control operations on an I/O switch attached for file transfer */ imft_hasp_control: entry (P_iocb_ptr, P_order, P_info_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> attach_data_ptr; call iox_$control (iad.switch.terminal_iocb_ptr, P_order, P_info_ptr, P_code); /* just pass all orders on */ return; /* */ /* Change modes: no modes are supported */ imft_hasp_modes: entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; P_old_modes = ""; /* no modes are reflected to caller */ if P_new_modes = "" then P_code = 0; else P_code = error_table_$bad_mode; return; /* */ /* Transmit a logical record to the remote system as multiple physical records */ imft_hasp_write_record: entry (P_iocb_ptr, P_record_ptr, P_record_length, P_code); iocb_ptr = P_iocb_ptr; ilr_ptr = P_record_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; logical_record_data_ptr = addr (imft_logical_record.contents); logical_record_data_lth = imft_logical_record.length; terminal_io_record_ptr = addr (iad.switch.tior); ipr_ptr = addr (terminal_io_record.data); unspec (imft_physical_record) = ""b; /* start out clean */ /* logical record header is sent as a separate physical record, which is always binary */ imft_physical_record.binary = "1"b; imft_physical_record.bolr = "1"b; imft_physical_record.eolr = (logical_record_data_lth = 0); call unpack (ilr_ptr, addr (imft_physical_record.data), length (unspec (imft_logical_record_header)), unpacked_chars); imft_physical_record.n_els.low_order = bit (bin (unpacked_chars, 7), 7); /* this assumes that the length of the header will always fit in 7 bits */ call transmit_physical_record (unpacked_chars, P_code); if P_code ^= 0 then return; imft_physical_record.bolr = "0"b; /* Now send the rest of the data (if any), unpacking only if necessary */ amount_sent = 0; if logical_record_data_lth ^= 0 then if imft_logical_record.binary | imft_logical_record.eight_bit then do; /* Binary data: unpack 7 bits at a time into 9 bit forming valid ASCII characters for transmission. At some future time, support for binary transmission should be provided */ logical_record_data_bits_lth = N_BITS_PER_CHARACTER * logical_record_data_lth; do while (amount_sent < logical_record_data_bits_lth); imft_physical_record.binary = "1"b; amount_left = logical_record_data_bits_lth - amount_sent; amount_to_send = min (amount_left, IMFT_PHYSICAL_RECORD_DATA_BITS_LTH); /* are using 7 bits per character */ call unpack (addbitno (logical_record_data_ptr, amount_sent), addr (imft_physical_record.data), amount_to_send, unpacked_chars); fb14uu = unpacked_chars; /* put # of characters in record into the record */ imft_physical_record.n_els.high_order = substr (unspec (fb14uu), 1, 7); imft_physical_record.n_els.low_order = substr (unspec (fb14uu), 8, 7); if amount_to_send = amount_left then /* last physical record */ imft_physical_record.eolr = "1"b; call transmit_physical_record (unpacked_chars, P_code); /* zap! */ if P_code ^= 0 then return; amount_sent = amount_sent + amount_to_send; end; end; else do; /* Character only data */ do while (amount_sent < logical_record_data_lth); amount_left = logical_record_data_lth - amount_sent; amount_to_send = min (amount_left, IMFT_PHYSICAL_RECORD_DATA_LTH); /* determine how much to send now */ imft_physical_record.data = substr (logical_record_data, (amount_sent + 1), amount_to_send); fb14uu = amount_to_send; /* put # of characters in record into the record */ imft_physical_record.n_els.high_order = substr (unspec (fb14uu), 1, 7); imft_physical_record.n_els.low_order = substr (unspec (fb14uu), 8, 7); if amount_to_send = amount_left then /* last physical record */ imft_physical_record.eolr = "1"b; call transmit_physical_record (amount_to_send, P_code); /* zap! */ if P_code ^= 0 then return; amount_sent = amount_sent + amount_to_send; end; end; return; /* */ /* Receive the contents of a logical record from the remote system */ imft_hasp_read_record: entry (P_iocb_ptr, P_buffer_ptr, P_buffer_max_lth, P_record_length, P_code); iocb_ptr = P_iocb_ptr; ilr_ptr = P_buffer_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; terminal_io_record_ptr = addr (iad.switch.tior); ipr_ptr = addr (terminal_io_record.data); /* read header record (which is always binary) */ call receive_physical_record (n_bytes, P_code); if P_code ^= 0 then return; if ^imft_physical_record.bolr /* not first in logical record? */ then do; P_code = error_table_$improper_data_format; return; end; call pack (addr (imft_physical_record.data), ilr_ptr, n_bytes, packed_length); if imft_logical_record.version ^= IMFT_LOGICAL_RECORD_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if 4 * size (imft_logical_record_header) + imft_logical_record.length > P_buffer_max_lth /* record is too big to fit in caller's buffer */ then do; P_code = error_table_$long_record; return; end; /* now read the physical records (if any) that contain the data portion of the logical record */ data_received = 0; unspec (imft_logical_record.contents) = ""b; /* start clean */ if imft_logical_record.binary | imft_logical_record.eight_bit then do; logical_record_data_bits_lth = 9 * imft_logical_record.length; /* have to work in bits in this case */ do while (data_received < logical_record_data_bits_lth & ^imft_physical_record.eolr); /* should run out of data exactly when eolr goes on */ call receive_physical_record (n_bytes, P_code); if P_code ^= 0 then return; call pack (addr (imft_physical_record.data), addbitno (addr (imft_logical_record.contents), data_received), n_bytes, packed_length); data_received = data_received + packed_length; end; data_received = divide (data_received, 9, 21, 0); /* now convert to characters */ /* note that real data ends on 9-bit boundary */ end; else do while (data_received < imft_logical_record.length & ^imft_physical_record.eolr); /* these two conditions SHOULD be equivalent */ call receive_physical_record (n_bytes, P_code); if P_code ^= 0 then return; /* just copy the data directly */ addcharno (addr (imft_logical_record.contents), data_received) -> data_bytes = addr (imft_physical_record.data) -> data_bytes; data_received = data_received + n_bytes; end; if data_received < imft_logical_record.length /* premature end_of_record flag */ then P_code = error_table_$eof_record; /* it should probably be something else */ else if ^imft_physical_record.eolr /* used up length before finding end-of-record */ then P_code = error_table_$long_record; /* which means next record is probably messed up too */ else P_code = 0; P_record_length = 4 * size (imft_logical_record_header) + data_received; return; /* */ /* Cleanup whatever portion of an attachment exists */ cleanup_attachment: procedure (P_code); dcl P_code fixed binary (35) parameter; /* a parameter to allow callers to ignore it */ P_code = 0; if iad_ptr ^= null () then do; /* there is an I/O switch */ if iad.switch.terminal_iocb_ptr ^= null () then do; call iox_$close (iad.switch.terminal_iocb_ptr, (0)); call iox_$detach_iocb (iad.switch.terminal_iocb_ptr, P_code); call iox_$destroy_iocb (iad.switch.terminal_iocb_ptr, (0)); iad.switch.terminal_iocb_ptr = null (); end; free iad in (system_area); iad_ptr = null (); end; return; end cleanup_attachment; /* */ /* Wrapper to protect against errors while IPS interrupts are masked */ any_other_handler: procedure () options (non_quick); if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask); ips_mask = ""b; call continue_to_signal_ ((0)); /* not interested, */ return; end any_other_handler; /* Abort a call to the attach entry: print an error message if requested */ abort_attachment: procedure () options (variable, non_quick); dcl the_code fixed binary (35) based (the_code_ptr); dcl the_code_ptr pointer; dcl caller_message character (256); call cu_$arg_ptr (1, the_code_ptr, (0), (0)); if loud_sw then do; /* an error message is requested */ call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, (0), "1"b, "0"b); call com_err_ (the_code, IMFT_HASP_, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message); end; call cleanup_attachment ((0)); /* get rid of anything that was accomplished */ if the_code = 0 then code = error_table_$action_not_performed; else code = the_code; /* save the error code */ go to RETURN_FROM_ATTACH; end abort_attachment; /* */ /* transmits a single physical record */ transmit_physical_record: procedure (n_bytes, code); dcl n_bytes fixed bin (21); dcl code fixed binary (35); terminal_io_record.element_size = 9; terminal_io_record.n_elements = n_bytes + 4; /* make sure they're still correct */ terminal_io_record.version = terminal_io_record_version_1; call iox_$write_record (iad.switch.terminal_iocb_ptr, terminal_io_record_ptr, (4 * currentsize (terminal_io_record)), code); unspec (imft_physical_record) = ""b; /* start next record clean */ return; end transmit_physical_record; /* */ /* read a single physical HASP record */ receive_physical_record: procedure (bytes_read, code); dcl bytes_read fixed bin (21); dcl code fixed binary (35); dcl fb14uu fixed binary (14) unaligned unsigned; terminal_io_record.element_size = 9; terminal_io_record.n_elements = IMFT_PHYSICAL_RECORD_LTH; terminal_io_record.version = terminal_io_record_version_1; call iox_$read_record (iad.switch.terminal_iocb_ptr, terminal_io_record_ptr, (4 * currentsize (terminal_io_record)), (0), code); if code = error_table_$short_record then code = 0; if code ^= 0 then return; unspec (fb14uu) = imft_physical_record.n_els.high_order || imft_physical_record.n_els.low_order; bytes_read = fb14uu; /* record # of characters or bytes */ return; end receive_physical_record; /* */ /* pair of subroutines for converting between 7 bits/byte and 9 bits/byte */ pack_unpack: procedure; return; /* not to be called */ dcl packed_byte_ptr pointer parameter; dcl unpacked_byte_ptr pointer parameter; dcl P_input_chars fixed bin (21) parameter; dcl P_input_bits fixed bin (21) parameter; dcl P_output_chars fixed bin (21) parameter; dcl P_output_bits fixed bin (21) parameter; dcl unpacked_length fixed bin; dcl packed_bytes (unpacked_length) bit (7) unaligned based (packed_byte_ptr); dcl unpacked_bytes (unpacked_length) bit (9) unaligned based (unpacked_byte_ptr); pack: entry (unpacked_byte_ptr, packed_byte_ptr, P_input_chars, P_output_bits); /* input has 2 high-order bits of every 9 off, + 7 data bits; pack it into binary */ unpacked_length = P_input_chars; P_output_bits = 7 * unpacked_length; packed_bytes = substr (unpacked_bytes, 3); /* simple as that! */ return; unpack: entry (packed_byte_ptr, unpacked_byte_ptr, P_input_bits, P_output_chars); /* input is binary; unpack it so that 2 high-order bits of every 9 are 0 */ P_output_chars, unpacked_length = divide (P_input_bits + 6, 7, 21, 0); string (unpacked_bytes) = ""b; substr (unpacked_bytes, 3) = packed_bytes; /* it works in this direction, too */ return; end pack_unpack; /* */ %include iocb; %page; %include iox_modes; %page; %include imft_logical_record; %page; %include terminal_io_record; end imft_hasp_;  imft_io_.pl1 11/14/88 1517.9rew 11/14/88 1511.2 461907 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* I/O module to transmit files between Multics sites using I/O daemon record oriented communications modules */ /* Created: October 1980 by G. Palter */ /* Modified: April 1982 by G. Palter to greatly simplify attach description and internal operation */ /* Modified: 26 July 1982 by G. Palter to add get_channel_names control order */ /* Modified: January 1983 by Robert Coren for communications independence */ /* Modified: June 1983 by Robert Coren to mask quits when calling iox_$write_record */ /* Modified: September 1983 by Robert Coren to hold quits during calls to iox_$write_record instead of masking them */ /* Modified: September 1983 by Robert Coren to pad the allocated record buffers by an extra word */ /****^ HISTORY COMMENTS: 1) change(87-11-15,Oke), approve(88-08-01,MCR7948), audit(88-10-11,Farley), install(88-10-14,MR12.2-1165): Add support for "get_transport_line" and "put_transport_chars" control orders. 2) change(88-11-10,Beattie), approve(88-08-01,PBF7948), audit(88-11-14,Farley), install(88-11-14,MR12.2-1214): Check records for negative length to prevent invalid data from the IO channel causing problems. Remove check for bad version or data format if first read. See note in receive_logical_control_record entry point. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ imft_io_: procedure (); return; /* not an entry */ /* Attach an I/O switch for file transfer */ imft_io_attach: entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code); iocb_ptr = P_iocb_ptr; loud_sw = P_loud_sw; code = 0; iad_ptr = null (); /* avoid freeing garbage if I/O switch already attached */ if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do; P_code = error_table_$not_detached; if loud_sw then call com_err_ (P_code, IMFT_IO_, "For switch ^a.", iocb_ptr -> iocb.name); return; end; system_area_ptr = get_system_free_area_ (); on condition (cleanup) call cleanup_attachment (ignore_code); call create_ips_mask_ (addr (QUIT_NAME), 1, quit_mask); /* we'll need this to mask quits while writing */ mask_quits = quit_mask; /* but hcs_$set_ips_mask wants it unaligned */ /* Process attachment options */ if hbound (P_attach_options, 1) < 1 then call abort_attachment (error_table_$noarg, """-direction"", ""-input_description"", and ""-output_description"" must be supplied."); allocate iad in (system_area) set (iad_ptr); iad.input_switch.terminal_iocb_ptr, /* keeps cleanup handler happy */ iad.output_switch.terminal_iocb_ptr, iad.input_switch.record_buffer_ptr, iad.output_switch.record_buffer_ptr = null (); direction = ""; /* haven't seen -direction yet */ input_description_idx = 0; /* haven't seen -input_description yet */ output_description_idx = 0; /* haven't seen -output_description yet */ io_description_idx = 0; /* nor -io_description */ iad.debug_mode = "0"b; /* haven't seen -debug yet */ iad.copy_data = "0"b; /* haven't seen -copy_data yet */ iad.attach_description = ""; iad.open_description = ""; do argument_idx = lbound (P_attach_options, 1) to hbound (P_attach_options, 1); argument_ptr = addr (addr (P_attach_options (argument_idx)) -> string_overlay.characters (1)); argument_lth = length (P_attach_options (argument_idx)); if argument = "-direction" then do; direction = get_string_argument (); if (direction ^= "input") & (direction ^= "output") then call abort_attachment (error_table_$bad_arg, "-direction must be followed by ""input"" or ""output""; not ""^a"".", direction); end; else if (argument = "-input_description") | (argument = "-ids") then do; an_attach_description = get_string_argument (); input_description_idx = argument_idx; end; else if (argument = "-output_description") | (argument = "-ods") then do; an_attach_description = get_string_argument (); output_description_idx = argument_idx; end; else if (argument = "-io_description") | (argument = "-iods") then do; an_attach_description = get_string_argument (); io_description_idx = argument_idx; end; else if argument = "-debug" then iad.debug_mode = "1"b; else if argument = "-copy_data" then iad.copy_data = "1"b; else call abort_attachment (error_table_$badopt, """^a""", argument); end; if direction = "" then call abort_attachment (error_table_$noarg, "-direction"); if io_description_idx = 0 then do; if input_description_idx = 0 then call abort_attachment (error_table_$noarg, "-input_description"); if output_description_idx = 0 then call abort_attachment (error_table_$noarg, "-output_description"); end; else if input_description_idx ^= 0 | output_description_idx ^= 0 then call abort_attachment (error_table_$inconsistent, "-io_description and -input_ or -output_description"); /* Construct our attach description */ iad.attach_description = rtrim (IMFT_IO_); iad.attach_description = iad.attach_description || " -direction "; iad.attach_description = iad.attach_description || rtrim (direction); if io_description_idx ^= 0 /* single switch for both input and output */ then do; argument_ptr = addr (addr (P_attach_options (io_description_idx)) -> string_overlay.characters (1)); argument_lth = length (P_attach_options (io_description_idx)); iad.attach_description = iad.attach_description || " -io_description " || requote_string_ (argument); end; else do; argument_ptr = addr (addr (P_attach_options (input_description_idx)) -> string_overlay.characters (1)); argument_lth = length (P_attach_options (input_description_idx)); iad.attach_description = iad.attach_description || " -input_description "; iad.attach_description = iad.attach_description || requote_string_ (argument); argument_ptr = addr (addr (P_attach_options (output_description_idx)) -> string_overlay.characters (1)); argument_lth = length (P_attach_options (output_description_idx)); iad.attach_description = iad.attach_description || " -output_description "; iad.attach_description = iad.attach_description || requote_string_ (argument); end; /* Attach through the terminal level */ iad.input_direction = (direction = "input"); terminal_attach_count = terminal_attach_count + 1; if terminal_attach_count > 999 then terminal_attach_count = 1; if io_description_idx ^= 0 /* only need to attach one switch */ then do; terminal_switch_name = rtrim (IMFT_IO_) || ".input_output." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count)); call iox_$attach_ioname (terminal_switch_name, terminal_iocb_ptr, "imft_" || P_attach_options (io_description_idx), code); if code ^= 0 then call abort_attachment (code, "Unable to attach channel via: imft_^a", P_attach_options (io_description_idx)); iad.input_switch.terminal_iocb_ptr, iad.output_switch.terminal_iocb_ptr = terminal_iocb_ptr; end; else do; /* have to attach separate input and output switches */ terminal_switch_name = rtrim (IMFT_IO_) || ".input." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count)); call iox_$attach_ioname (terminal_switch_name, terminal_iocb_ptr, "imft_" || P_attach_options (input_description_idx), code); if code ^= 0 then call abort_attachment (code, "Unable to attach input channel via: ^a", P_attach_options (input_description_idx)); iad.input_switch.terminal_iocb_ptr = terminal_iocb_ptr; terminal_switch_name = rtrim (IMFT_IO_) || ".output." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count)); call iox_$attach_ioname (terminal_switch_name, terminal_iocb_ptr, "imft_" || P_attach_options (output_description_idx), code); if code ^= 0 then call abort_attachment (code, "Unable to attach output channel via: ^a", P_attach_options (output_description_idx)); iad.output_switch.terminal_iocb_ptr = terminal_iocb_ptr; end; if iad.copy_data then do; debug_switch_name = "imft.debug." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count)); call ioa_$rsnnl ("^a>^a.^[i^;o^]", debug_file_name, ignore_fb21, rtrim (get_wdir_ ()), debug_switch_name, iad.input_direction); call iox_$attach_ioname (debug_switch_name, debug_iocb_ptr, "vfile_ " || debug_file_name || " -extend", code); if code ^= 0 then call com_err_ (code, IMFT_IO_, "Trying to attach debug file."); end; /* Initialize the input and output terminal switch structures */ string (iad.input_switch.flags), string (iad.output_switch.flags) = ""b; iad.input_switch.data_length = 0; iad.input_switch.rest_of_record_ptr = null (); /* allocate buffers for active records */ /* include an extra word of padding so that I/O modules that work in 8-bit bytes won't go off the end */ imft_logical_record_length = IMFT_MAX_RECORD_LENGTH + 4; allocate imft_logical_record in (system_area) set (iad.input_switch.record_buffer_ptr); allocate imft_logical_record in (system_area) set (iad.output_switch.record_buffer_ptr); iad.abort_in_progress = "0"b; /* didn't encounter any errors yet */ iad.abort_code = 0; /* Mask and complete construction of the IOCB */ ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (MASK_OFF, ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = addr (iad.attach_description); iocb_ptr -> iocb.attach_data_ptr = iad_ptr; iocb_ptr -> iocb.open = imft_io_open; iocb_ptr -> iocb.detach_iocb = imft_io_detach; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); RETURN_FROM_ATTACH: P_code = code; return; %page; /* Open an I/O switch for file transfer */ imft_io_open: entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; open_mode = P_open_mode; if ^((iad.input_direction & (open_mode = Stream_input)) | (^iad.input_direction & (open_mode = Stream_output))) then do; /* opening mode and direction must agree */ P_code = error_table_$bad_mode; return; end; if iad.input_switch.terminal_iocb_ptr = iad.output_switch.terminal_iocb_ptr then do; call iox_$open (iad.input_switch.terminal_iocb_ptr, Sequential_input_output, "0"b, P_code); if P_code ^= 0 then return; end; else do; call iox_$open (iad.input_switch.terminal_iocb_ptr, Sequential_input, "0"b, P_code); if P_code ^= 0 then return; call iox_$open (iad.output_switch.terminal_iocb_ptr, Sequential_output, "0"b, P_code); if P_code ^= 0 then do; /* must close the other one to stay happy */ call iox_$close (iad.input_switch.terminal_iocb_ptr, ignore_code); return; end; end; iad.input_switch.first_read = "1"b; /* so we can know to throw out old garbage */ call iox_$control (iad.output_switch.terminal_iocb_ptr, "resetwrite", null (), 0); iad.open_description = rtrim (iox_modes (open_mode)); if iad.copy_data then call iox_$open (debug_iocb_ptr, Stream_output, "0"b, ignore_code); ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (MASK_OFF, ips_mask); if iad.input_direction then iocb_ptr -> iocb.get_chars, iocb_ptr -> iocb.get_line = imft_io_get_chars; else iocb_ptr -> iocb.put_chars = imft_io_put_chars; iocb_ptr -> iocb.control = imft_io_control; iocb_ptr -> iocb.modes = imft_io_modes; iocb_ptr -> iocb.close = imft_io_close; iocb_ptr -> iocb.detach_iocb = imft_io_detach; iocb_ptr -> iocb.open_descrip_ptr = addr (iad.open_description); /* it's now open */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = 0; return; %page; /* Close an I/O switch used for file transfer */ imft_io_close: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; code = 0; if iocb_ptr -> iocb.open_descrip_ptr = null () then do; P_code = error_table_$not_open; return; end; if iad.input_switch.terminal_iocb_ptr = iad.output_switch.terminal_iocb_ptr then do; call iox_$control (iad.input_switch.terminal_iocb_ptr, "abort", null (), 0); /* clean it out first */ call iox_$close (iad.input_switch.terminal_iocb_ptr, code); if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0; end; else do; call iox_$control (iad.output_switch.terminal_iocb_ptr, "abort", null (), 0); call iox_$control (iad.input_switch.terminal_iocb_ptr, "abort", null (), 0); /* clean out both switches */ call iox_$close (iad.output_switch.terminal_iocb_ptr, code); if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0; call iox_$close (iad.input_switch.terminal_iocb_ptr, code); if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0; end; if iad.copy_data then call iox_$close (debug_iocb_ptr, ignore_code); ips_mask = ""b; on condition (cleanup) call any_other_handler (); call hcs_$set_ips_mask (MASK_OFF, ips_mask); iocb_ptr -> iocb.open_descrip_ptr = null (); iocb_ptr -> iocb.open = imft_io_open; iocb_ptr -> iocb.detach_iocb = imft_io_detach; iocb_ptr -> iocb.control, iocb_ptr -> iocb.modes, iocb_ptr -> iocb.get_chars, iocb_ptr -> iocb.get_line, iocb_ptr -> iocb.put_chars = iox_$err_no_operation; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = code; return; %page; /* Detach an I/O switch from file transfer */ imft_io_detach: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr; code = 0; if iocb_ptr -> iocb.attach_descrip_ptr = null () then do; P_code = error_table_$not_attached; return; end; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; system_area_ptr = get_system_free_area_ (); iad_ptr = iocb_ptr -> iocb.attach_data_ptr; call cleanup_attachment (code); ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (MASK_OFF, ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = null (); /* it's detached */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = code; /* in case trouble freeing the channel */ return; %page; /* Write data records to the remote Multics: formats the user's data stream into IMFT logical records and transmits them to the remote Multics. If any errors are detected while writing, this I/O module signals the "imft_write_abort_" condition which imft_transmit_object_ handles through the "get_abort_info" control order */ imft_io_put_chars: entry (P_iocb_ptr, P_data_ptr, P_data_lth, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; code = 0; if iad.input_direction then do; /* can't write the input side of a pipe */ P_code = error_table_$invalid_write; return; end; total_data = P_data_lth; data_ptr = P_data_ptr; data_sent = 0; do while (data_sent < total_data); chars_to_send = min (IMFT_MAX_RECORD_LENGTH, total_data - data_sent); call transmit_logical_data_record (IMFT_DATA, data_ptr, chars_to_send); /* does the actual work */ data_sent = data_sent + chars_to_send; data_ptr = addcharno (data_ptr, chars_to_send); end; P_code = code; return; %page; /* Read data records from the remote Multics: reads requested number of data characters from the remote system. Data is read until either the user's buffer is filled or a control record is encountered. If a control record is read before any data is found or an I/O error occurs during a read, the condition "imft_read_abort_" is signalled which is recognized by the caller. The reason for the termination of the read request can be determined by the "get_abort_info" control order. If the last whole record read won't fit in the caller's buffer, the remainder is held in record_buffer, and input_switch.rest_of_record_ptr points to it. */ imft_io_get_chars: entry (P_iocb_ptr, P_buffer_ptr, P_buffer_max_length, P_data_lth, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; if ^iad.input_direction then do; /* attempt to read the "punch" */ P_code = error_table_$invalid_read; return; end; if iad.input_switch.control_record_present then call abort_read_operation (NO_ERROR); buffer_used = 0; buffer_max_length = P_buffer_max_length; continue = "1"b; do while (buffer_used < buffer_max_length & continue); if iad.input_switch.data_present /* data left over from previous read */ then do; chars_to_copy = min (iad.input_switch.data_length, buffer_max_length - buffer_used); substr (caller_buffer, buffer_used + 1, chars_to_copy) = substr (rest_of_record, 1, chars_to_copy); buffer_used = buffer_used + chars_to_copy; iad.input_switch.data_length = iad.input_switch.data_length - chars_to_copy; if iad.input_switch.data_length > 0 then iad.input_switch.rest_of_record_ptr = addcharno (iad.input_switch.rest_of_record_ptr, chars_to_copy); else iad.input_switch.data_present = "0"b; end; if buffer_used < buffer_max_length /* haven't filled caller's buffer yet */ then do; ilr_ptr = iad.input_switch.record_buffer_ptr; imft_logical_record.version = IMFT_LOGICAL_RECORD_VERSION_1; call iox_$read_record (iad.input_switch.terminal_iocb_ptr, ilr_ptr, 4 * size (imft_logical_record_header) + IMFT_MAX_RECORD_LENGTH, record_length, code); if code = error_table_$short_record then code = 0; /* "short" records are perfectly OK */ if code ^= 0 then call abort_read_operation (code); if iad.copy_data then do; call iox_$put_chars (debug_iocb_ptr, addr (MARKER), length (MARKER), ignore_code); call iox_$put_chars (debug_iocb_ptr, ilr_ptr, record_length, ignore_code); end; if imft_logical_record.type ^= IMFT_DATA/* oops, this is a control record */ then do; /* save it be read by the appropriate control operation */ iad.input_switch.data_present = "0"b; iad.input_switch.control_record_present = "1"b; /* for the use of the next read of either type */ iad.input_switch.data_length = record_length; /* next read_control_record can just scoop it out */ iad.input_switch.rest_of_record_ptr = ilr_ptr; continue = "0"b; /* but mustn't read any more right now */ if buffer_used = 0 /* there was no data to return */ then call abort_read_operation (NO_ERROR); end; else do; /* it's data, just as we hoped */ chars_to_copy = min (imft_logical_record.length, buffer_max_length - buffer_used); substr (caller_buffer, buffer_used + 1, chars_to_copy) = substr (imft_logical_record.contents, 1, chars_to_copy); buffer_used = buffer_used + chars_to_copy; if chars_to_copy < imft_logical_record.length /* couldn't take it all */ then do; iad.input_switch.data_present = "1"b; /* save it for next time */ iad.input_switch.data_length = imft_logical_record.length - chars_to_copy; iad.input_switch.rest_of_record_ptr = addcharno (addr (imft_logical_record.contents), chars_to_copy); end; else iad.input_switch.data_present = "0"b; end; end; end; P_data_lth = buffer_used; P_code = 0; /* here iff successful */ return; %page; /* Perform control operations on an I/O switch attached for file transfer */ imft_io_control: entry (P_iocb_ptr, P_order, P_info_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; order = P_order; info_ptr = P_info_ptr; code = 0; if order = "write_command_record" then do; /* Write a command record: Commands are sent by an output driver to the remote system's input driver to instruct the input driver as to what it should do next (begin reception of an object, abort, synchronize, etc.) */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version; else if iad.input_direction then /* must be transmitting data */ code = error_table_$invalid_write; else do; icri_ptr = info_ptr; if icri.timeout > 0 then do; /* trap no response */ call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout); on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); end; call transmit_logical_control_record ((icri.record_type), icri.record_ptr, icri.record_lth, code); call timer_manager_$reset_alarm_call (read_write_timeout); end; end; else if order = "read_command_record" then do; /* Read a command record: any intervening data records are discarded */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version; else if ^iad.input_direction then /* must be receiving data to receive control records */ code = error_table_$invalid_read; else do; icri_ptr = info_ptr; if icri.timeout > 0 then do; /* trap no response */ call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout); on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); end; call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth, icri.record_type, code); call timer_manager_$reset_alarm_call (read_write_timeout); end; end; else if order = "write_reply_record" then do; /* Write a reply record: Reply records are often sent by an input driver in response to a command record and indicate the input driver's reasons for accepting or rejecting a command */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version; else if ^iad.input_direction then /* must be receive side of a connection */ code = error_table_$invalid_write; else do; icri_ptr = info_ptr; if icri.timeout > 0 then do; /* trap no response */ call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout); on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); end; call transmit_logical_control_record ((icri.record_type), icri.record_ptr, icri.record_lth, code); call timer_manager_$reset_alarm_call (read_write_timeout); end; end; else if order = "read_reply_record" then do; /* Read a reply record */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version; else if iad.input_direction then /* must be transmitting side of connection */ code = error_table_$invalid_read; else do; icri_ptr = info_ptr; if icri.timeout > 0 then do; /* trap no response */ call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout); on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); end; call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth, icri.record_type, code); call timer_manager_$reset_alarm_call (read_write_timeout); end; end; else if order = "get_abort_info" then do; /* Return cause of previous get_chars or put_chars failure */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version; else do; icri_ptr = info_ptr; if iad.abort_in_progress then do; /* something did indeed go wrong */ iad.abort_in_progress = "0"b; if (iad.abort_code ^= 0) & (iad.abort_code ^= imft_et_$reply_pending) then do; /* I/O error during read/write */ icri.record_type = IMFT_ABORT; abort_command_ptr = icri.record_ptr; abort_command.reason = IMFT_ABORT_LOCAL_IO_ERROR; abort_command.code = iad.abort_code; icri.record_lth = 4 * currentsize (abort_command); end; /* let caller see exact error */ else do; /* encountered a control record: return it */ call timer_manager_$alarm_call (ONE_MINUTE, RELATIVE_SECONDS, read_write_timeout); on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth, icri.record_type, code); call timer_manager_$reset_alarm_call (read_write_timeout); end; end; else code = error_table_$no_operation; /* no abort was happening */ end; end; else if order = "get_channel_names" then do; /* Return the names of the channels attached through this switch */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> get_channel_names.version ^= GET_CHANNEL_NAMES_VERSION_1 then code = error_table_$unimplemented_version; else do; get_channel_names_ptr = info_ptr; local_tgci.version = tty_get_channel_info_version; call iox_$control (iad.input_switch.terminal_iocb_ptr, "get_channel_info", addr (local_tgci), code); if code = 0 then do; /* got the input channel ... */ get_channel_names.input_channel = local_tgci.channel_name; call iox_$control (iad.output_switch.terminal_iocb_ptr, "get_channel_info", addr (local_tgci), code); if code = 0 then /* ... and got the output channel */ get_channel_names.output_channel = local_tgci.channel_name; end; if code ^= 0 then /* couldn't get one of the channel names */ if code = error_table_$undefined_order_request then code = imft_et_$cant_get_channel_names; end; end; else if (order = "read_status") | (order = "resetread") then call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code); /* always apply these to the input connection */ else if (order = "write_status") | (order = "resetwrite") | (order = "runout") then call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code); /* always apply these to the output connection */ else if order = "abort" then do; /* always apply this to both switches */ call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code); if iad.input_switch.terminal_iocb_ptr ^= iad.output_switch.terminal_iocb_ptr then call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code); end; /* Handle handshaking IO for connection protocol. */ else if order = "get_transport_line" then do; icri_ptr = info_ptr; if icri.timeout > 0 then do; /* trap no response */ on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout); end; if iad.input_switch.terminal_iocb_ptr ^= null () then call iox_$get_line (iad.input_switch.terminal_iocb_ptr, icri.record_ptr, icri.record_max_lth, icri.record_lth, code); else call iox_$get_line (iad.output_switch.terminal_iocb_ptr, icri.record_ptr, icri.record_max_lth, icri.record_lth, code); if icri.timeout > 0 then do; call timer_manager_$reset_alarm_call (read_write_timeout); revert condition (cleanup); end; end; else if order = "put_transport_chars" then do; icri_ptr = info_ptr; if icri.timeout > 0 then do; /* trap no response */ on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout); end; if iad.input_switch.terminal_iocb_ptr ^= null () then call iox_$put_chars (iad.input_switch.terminal_iocb_ptr, icri.record_ptr, icri.record_lth, code); else call iox_$put_chars (iad.output_switch.terminal_iocb_ptr, icri.record_ptr, icri.record_lth, code); if icri.timeout > 0 then do; call timer_manager_$reset_alarm_call (read_write_timeout); revert condition (cleanup); end; end; else do; /* pass others on to the appropriate half of the connection */ if iad.input_direction then call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code); else call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code); end; RETURN_FROM_IMFT_CONTROL: P_code = code; return; %page; /* Internal procedure which is invoked when a read/write of a command/reply record times out */ read_write_timeout: procedure (); code = imft_et_$timeout; if iad.debug_mode then /* give the programmer a chance when debugging */ signal condition (imft_debug_); go to RETURN_FROM_IMFT_CONTROL; end read_write_timeout; /* */ /* Change modes: no modes are supported */ imft_io_modes: entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; P_old_modes = ""; /* no modes are reflected to caller */ if P_new_modes = "" then P_code = 0; else P_code = error_table_$bad_mode; return; %page; /* Cleanup whatever portion of an attachment exists */ cleanup_attachment: procedure (P_code); dcl P_code fixed binary (35) parameter; /* a parameter to allow callers to ignore it */ P_code = 0; if iad_ptr ^= null () then do; /* there is an I/O switch */ if iad.input_switch.terminal_iocb_ptr ^= null () then do; call iox_$close (iad.input_switch.terminal_iocb_ptr, ignore_code); call iox_$detach_iocb (iad.input_switch.terminal_iocb_ptr, P_code); call iox_$destroy_iocb (iad.input_switch.terminal_iocb_ptr, ignore_code); iad.input_switch.terminal_iocb_ptr = null (); end; if iad.output_switch.terminal_iocb_ptr ^= null () then do; call iox_$close (iad.output_switch.terminal_iocb_ptr, ignore_code); call iox_$detach_iocb (iad.output_switch.terminal_iocb_ptr, P_code); call iox_$destroy_iocb (iad.output_switch.terminal_iocb_ptr, ignore_code); iad.output_switch.terminal_iocb_ptr = null (); end; if iad.input_switch.record_buffer_ptr ^= null () then do; free iad.input_switch.record_buffer_ptr -> imft_logical_record in (system_area); iad.input_switch.record_buffer_ptr = null (); end; if iad.output_switch.record_buffer_ptr ^= null () then do; free iad.output_switch.record_buffer_ptr -> imft_logical_record in (system_area); iad.output_switch.record_buffer_ptr = null (); end; if debug_iocb_ptr ^= null () then do; call iox_$close (debug_iocb_ptr, ignore_code); call iox_$detach_iocb (debug_iocb_ptr, ignore_code); call iox_$destroy_iocb (debug_iocb_ptr, ignore_code); debug_iocb_ptr = null (); end; free iad in (system_area); iad_ptr = null (); end; return; end cleanup_attachment; %page; /* Wrapper to protect against errors while IPS interrupts are masked */ any_other_handler: procedure () options (non_quick); if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask); ips_mask = ""b; call continue_to_signal_ (ignore_code); /* not interested, */ return; end any_other_handler; /* Abort a call to the attach entry: print an error message if requested */ abort_attachment: procedure () options (variable, non_quick); dcl the_code fixed binary (35) based (the_code_ptr); dcl the_code_ptr pointer; dcl caller_message character (256); call cu_$arg_ptr (1, the_code_ptr, ignore_fb21, ignore_code); if loud_sw then do; /* an error message is requested */ call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, ignore_fb21, "1"b, "0"b); call com_err_ (the_code, IMFT_IO_, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message); end; call cleanup_attachment (ignore_code); /* get rid of anything that was accomplished */ if the_code = 0 then code = error_table_$action_not_performed; else code = the_code; /* save the error code */ go to RETURN_FROM_ATTACH; end abort_attachment; %page; /* Invoked if an error arises during get_chars operation */ abort_read_operation: procedure (p_code); dcl p_code fixed binary (35) parameter; iad.abort_in_progress = "1"b; iad.abort_code = p_code; SIGNAL_RECEIVE_FAILURE_FOREVER: signal condition (imft_read_abort_); go to SIGNAL_RECEIVE_FAILURE_FOREVER; end abort_read_operation; %page; /* Fetch the next argument from the attach options and validate that it is a non-null character string */ get_string_argument: procedure () returns (character (*)); dcl option_name character (32); option_name = argument; /* about to move on to the next one */ if argument_idx = hbound (P_attach_options, 1) then call abort_attachment (error_table_$noarg, "Character string following ""^a"".", option_name); argument_idx = argument_idx + 1; argument_ptr = addr (addr (P_attach_options (argument_idx)) -> string_overlay.characters (1)); argument_lth = length (P_attach_options (argument_idx)); if argument = "" then call abort_attachment (0, "Character string following ""^a"" must be non-null.", option_name); return (argument); end get_string_argument; %page; /* Transmit a logical record to the remote system */ transmit_logical_record: procedure (); return; /* not an entry */ /* Parameters */ dcl P_logical_record_type fixed binary (7) unaligned unsigned parameter; /* type of record being transmitted */ dcl P_logical_record_data_ptr pointer parameter; /* -> the logical record */ dcl P_logical_record_data_lth fixed binary (21) parameter; /* length of logical record in characters */ dcl P_code fixed binary (35) parameter; /* control: status code */ /* Remaining declarations */ dcl logical_record_data character (logical_record_data_lth) unaligned based (logical_record_data_ptr); dcl logical_record_data_lth fixed binary (21); dcl logical_record_data_ptr pointer; dcl 1 trsi aligned like tty_read_status_info automatic; dcl 1 auto_event_info aligned like event_wait_info; dcl 1 write_status_info aligned, 2 event_channel fixed bin (71), 2 output_pending bit (1); dcl put_chars_operation bit (1) aligned; /* ON => iox_$put_chars (data records) */ dcl quit_pending bit (1); /* Transmit a data record: aborts by signalling imft_write_abort_ if an I/O error is encountered */ transmit_logical_data_record: entry (P_logical_record_type, P_logical_record_data_ptr, P_logical_record_data_lth); put_chars_operation = "1"b; go to TRANSMIT_COMMON; /* Transmit a control record: any errors are reflected to the caller */ transmit_logical_control_record: entry (P_logical_record_type, P_logical_record_data_ptr, P_logical_record_data_lth, P_code); P_code = 0; put_chars_operation = "0"b; TRANSMIT_COMMON: if ^iad.input_direction then do; /* output side: check for unexpected replies */ trsi.input_pending = "0"b; /* ... in case the next call fails */ call iox_$control (iad.input_switch.terminal_iocb_ptr, "read_status", addr (trsi), ignore_code); if trsi.input_pending then call abort_write_operation (imft_et_$reply_pending); end; ilr_ptr = iad.output_switch.record_buffer_ptr; logical_record_data_ptr = P_logical_record_data_ptr; logical_record_data_lth, imft_logical_record.length = P_logical_record_data_lth; imft_logical_record.version = IMFT_LOGICAL_RECORD_VERSION_1; imft_logical_record.type = P_logical_record_type; string (imft_logical_record.flags) = "0"b; if logical_record_data_lth > 0 then do; if verify (logical_record_data, substr (collate9 (), 1, 256)) ^= 0 /* there's some data with 9th bit on */ then imft_logical_record.binary = "1"b; else if verify (logical_record_data, collate ()) ^= 0 /* no 9-bit, but some 8-bit data */ then imft_logical_record.eight_bit = "1"b; imft_logical_record.contents = logical_record_data; end; /* in order to make sure the record isn't interrupted by a control record as a result of a QUIT followed by an operator command, intercept quits while writing the record, and signal them once we're done */ quit_pending = "0"b; on condition (quit) begin; quit_pending = "1"b; end; call iox_$write_record (iad.output_switch.terminal_iocb_ptr, ilr_ptr, 4 * size (imft_logical_record_header) + imft_logical_record.length, code); revert condition (quit); if code ^= 0 then call abort_write_operation (code); if quit_pending then do; call iox_$control (iad.output_switch.terminal_iocb_ptr, "write_status", addr (write_status_info), code); /* try to ensure that the record has really made it out of ring 0 */ do while ((code = 0) & write_status_info.output_pending); event_wait_channel.channel_id = write_status_info.event_channel; call ipc_$block (addr (event_wait_channel), addr (auto_event_info), code); if code = 0 then call iox_$control (iad.output_switch.terminal_iocb_ptr, "write_status", addr (write_status_info), code); end; signal condition (quit); end; if iad.copy_data then do; call iox_$put_chars (debug_iocb_ptr, addr (MARKER), length (MARKER), ignore_code); call iox_$put_chars (debug_iocb_ptr, ilr_ptr, 4 * size (imft_logical_record_header) + imft_logical_record.length, ignore_code); end; if ^put_chars_operation then /* here iff all written OK */ P_code = 0; RETURN_FROM_TRANSMIT_LOGICAL_RECORD: return; /* Internal to transmit_logical_record: aborts the current write operation */ abort_write_operation: procedure (p_code); dcl p_code fixed binary (35) parameter; if put_chars_operation then do; /* data stream: abort the operation completely */ iad.abort_in_progress = "1"b; iad.abort_code = p_code; SIGNAL_TRANSMISSION_FAILURE_FOREVER: signal condition (imft_write_abort_); go to SIGNAL_TRANSMISSION_FAILURE_FOREVER; end; /* imft_transmit_object_ shouldn't return */ else do; /* writing a control record: reflect error to caller */ P_code = p_code; go to RETURN_FROM_TRANSMIT_LOGICAL_RECORD; end; end abort_write_operation; end transmit_logical_record; %page; /* Receive the contents of a logical record from the remote system */ receive_logical_record: procedure (); return; /* not an entry */ dcl P_buffer_ptr pointer parameter; /* -> buffer to place record contents */ dcl P_buffer_max_length fixed binary (21) parameter; /* maximum size of buffer (in characters) */ dcl P_buffer_used fixed binary (21) parameter; /* # of characters placed into buffer */ dcl P_record_type fixed binary parameter; /* control: set to type of control record found */ dcl P_code fixed binary (35) parameter; /* control: status cod */ /* Remaining declarations */ dcl buffer_max_length fixed binary (21); dcl buffer_ptr pointer; dcl caller_buffer char (buffer_max_length) based (buffer_ptr); dcl found bit (1); /* Receive a control record: flushes all data records until a control record is found and returned */ receive_logical_control_record: entry (P_buffer_ptr, P_buffer_max_length, P_buffer_used, P_record_type, P_code); P_record_type = -1; /* haven't found it yet */ P_code = 0; buffer_ptr = P_buffer_ptr; buffer_max_length = P_buffer_max_length; found = "0"b; iad.input_switch.data_present = "0"b; /* if it was, we're ignoring it */ if iad.input_switch.control_record_present then ilr_ptr = iad.input_switch.rest_of_record_ptr; else do; ilr_ptr = iad.input_switch.record_buffer_ptr; imft_logical_record.version = IMFT_LOGICAL_RECORD_VERSION_1; do while (^found); /* keep reading until we find a control record */ call iox_$read_record (iad.input_switch.terminal_iocb_ptr, ilr_ptr, 4 * size (imft_logical_record_header) + IMFT_MAX_RECORD_LENGTH, record_length, code); if code = error_table_$short_record then code = 0; /* short_record is not interesting */ if code ^= 0 then do; /****^ Code here used to ignore codes error_table_$unimplemented_version and error_table_$improper_data_format on first read but this can leave both ends of a link waiting for the other to respond if garbage is received which is not good in production mode. At least imft_driver_$init will display the code and return and iodd_ will indicate that driver could not be initialized. These can be dealt with automatically. Previous code required manual intervention by site personnel to get drivers to try again. */ P_code = code; return; end; else do; if iad.copy_data then do; call iox_$put_chars (debug_iocb_ptr, addr (MARKER), length (MARKER), ignore_code); call iox_$put_chars (debug_iocb_ptr, ilr_ptr, record_length, ignore_code); end; iad.input_switch.first_read = "0"b; if imft_logical_record.type ^= IMFT_DATA /* it IS a control record */ then found = "1"b; end; end; end; if imft_logical_record.length < 0 | imft_logical_record.length > buffer_max_length then /* an overlong control record!? */ P_code = error_table_$invalid_record_length; else do; substr (caller_buffer, 1, imft_logical_record.length) = imft_logical_record.contents; P_buffer_used = imft_logical_record.length; P_record_type = imft_logical_record.type; P_code = 0; end; iad.input_switch.control_record_present = "0"b; return; end receive_logical_record; %page; /* Parameters */ dcl P_iocb_ptr pointer parameter; /* *: -> I/O switch being operated upon */ dcl P_code fixed binary (35) parameter; dcl P_attach_options (*) character (*) varying parameter; /* attach: attachment arguments */ dcl P_loud_sw bit (1) parameter; /* attach: ON => attachment errors should call com_err_ */ dcl P_open_mode fixed binary parameter; /* open: opening mode */ dcl P_open_sw bit (1) parameter; /* open: obsolete parameter */ dcl P_data_lth fixed binary (21) parameter; /* get_*: set to # of characters read into buffer; put_chars: # of characters to transmit as logical record */ dcl P_buffer_ptr pointer parameter; /* get_*: -> area to place result of read */ dcl P_buffer_max_length fixed binary (21) parameter; /* get_*: size of area in characters */ dcl P_data_ptr pointer parameter; /* put_chars: -> data stream to be written */ dcl P_order character (*) parameter; /* control: name of control order to be performed */ dcl P_info_ptr pointer parameter; /* control: -> additional information required to execute the control order */ dcl P_new_modes character (*) parameter; /* modes: new modes to be set */ dcl P_old_modes character (*) parameter; /* modes: set to modes in effect before change */ /* Local copies of parameters */ dcl iocb_ptr pointer; dcl code fixed binary (35); dcl ignore_code fixed binary (35); dcl ignore_fb21 fixed binary (21); dcl argument character (argument_lth) based (argument_ptr);/* based on attach options */ dcl argument_lth fixed binary (21); dcl argument_ptr pointer; dcl loud_sw bit (1) aligned; dcl open_mode fixed binary; dcl order character (32); dcl info_ptr pointer; /* Remaining declarations */ dcl 1 local_tgci aligned like tty_get_channel_info; /* for get_channel_names */ dcl system_area area aligned based (system_area_ptr); dcl system_area_ptr pointer; dcl argument_idx fixed binary; /* # of attach option being processed */ dcl direction character (32); dcl (input_description_idx, output_description_idx) fixed binary; dcl io_description_idx fixed binary; dcl an_attach_description character (512); dcl terminal_switch_name character (32); dcl terminal_iocb_ptr pointer; dcl terminal_attach_count fixed binary static initial (0); dcl terminal_attach_count_pic picture "999"; dcl ips_mask bit (36); dcl quit_mask bit (36) aligned; dcl buffer_used fixed bin (21); dcl buffer_max_length fixed bin (21); dcl continue bit (1); dcl record_length fixed bin (21); dcl chars_to_copy fixed bin (21); dcl total_data fixed bin (21); dcl data_sent fixed bin (21); dcl chars_to_send fixed bin (21); dcl data_ptr pointer; dcl IMFT_IO_ character (32) static options (constant) initial ("imft_io_"); dcl RELATIVE_SECONDS bit (2) static options (constant) initial ("11"b); dcl ONE_MINUTE fixed binary (71) static options (constant) initial (60); dcl MARKER character (4) static options (constant) initial ("REC:"); dcl MASK_OFF bit (36) initial ((36)"0"b) internal static options (constant); dcl NO_ERROR fixed binary (35) initial (0) internal static options (constant); dcl QUIT_NAME (1) char (32) aligned internal static options (constant) initial ("quit"); dcl mask_quits bit (36) internal static; /* IPS mask to prevent quits */ dcl debug_switch_name character (32); dcl debug_file_name character (168); dcl debug_iocb_ptr pointer internal static init (null ()); dcl caller_buffer char (buffer_max_length) based (P_buffer_ptr); /* structure for obtaining the address of the string portion of a varying character string */ dcl 1 string_overlay aligned based, 2 lth fixed binary (21), 2 characters (0 refer (string_overlay.lth)) character (1) unaligned; /* format: off */ dcl (error_table_$action_not_performed, error_table_$badopt, error_table_$bad_arg, error_table_$bad_mode, error_table_$inconsistent, error_table_$invalid_read, error_table_$invalid_write, error_table_$invalid_record_length, error_table_$noarg, error_table_$no_operation, error_table_$not_attached, error_table_$not_closed, error_table_$not_detached, error_table_$not_open, error_table_$null_info_ptr, error_table_$short_record, error_table_$undefined_order_request, error_table_$unimplemented_version) fixed binary (35) external; dcl (imft_et_$cant_get_channel_names, imft_et_$reply_pending, imft_et_$timeout) fixed binary (35) external; /* format: on */ dcl com_err_ entry () options (variable); dcl continue_to_signal_ entry (fixed binary (35)); dcl create_ips_mask_ entry (ptr, fixed bin, bit (36) aligned); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl get_wdir_ entry () returns (character (168)); dcl hcs_$reset_ips_mask entry (bit (36), bit (36)); dcl hcs_$set_ips_mask entry (bit (36), bit (36)); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1)); dcl ioa_$rsnnl entry options (variable); dcl iox_$attach_ioname entry (character (*), pointer, character (*), fixed binary (35)); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl iox_$close entry (pointer, fixed binary (35)); dcl iox_$destroy_iocb entry (pointer, fixed binary (35)); dcl iox_$detach_iocb entry (pointer, fixed binary (35)); dcl iox_$err_no_operation entry () options (variable); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$propagate entry (pointer); dcl iox_$read_record entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl iox_$write_record entry (pointer, pointer, fixed binary (21), fixed binary (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl requote_string_ entry (character (*)) returns (character (*)); dcl timer_manager_$alarm_call entry (fixed binary (71), bit (2), entry); dcl timer_manager_$reset_alarm_call entry (entry); dcl (any_other, cleanup, imft_debug_, imft_read_abort_, imft_write_abort_, quit) condition; dcl (addr, addcharno, collate, collate9, convert, currentsize, hbound, lbound, length, ltrim, min, null, rtrim, size, string, substr, verify) builtin; %page; /* Description of a switch attached through this module */ dcl 1 iad aligned based (iad_ptr), 2 attach_description character (1024) varying, /* attach description for this I/O switch */ 2 open_description character (24) varying, /* open description for this I/O switch */ 2 input_switch like switch_info, /* defines the input terminal switch */ 2 output_switch like switch_info, /* defines the output terminal switch */ 2 abort_code fixed binary (35), /* status code of last aborted I/O operation */ 2 flags aligned, 3 input_direction bit (1) unaligned, /* ON => receives data from remote system */ 3 abort_in_progress bit (1) unaligned, /* ON => last I/O operation failed */ 3 debug_mode bit (1) unaligned, /* ON => trying to debug IMFT: stop on errors */ 3 copy_data bit (1) unaligned, /* ON => trying to debug connection: copy all data */ 3 pad bit (32) unaligned; dcl iad_ptr pointer; /* Description of a single terminal level I/O switch */ dcl 1 switch_info aligned based, 2 terminal_iocb_ptr pointer, /* -> IOCB for terminal level module */ 2 record_buffer_ptr pointer, /* -> allocated buffer for active records */ 2 flags, 3 data_present bit (1) unaligned, /* part of a data record is held here */ 3 control_record_present bit (1) unaligned, /* a control record is waiting to be read */ 3 first_read bit (1) unaligned, /* no reads have been done since latest open */ 3 pad_bits bit (33) unaligned, 2 data_length fixed bin (21), /* number of characters in held record or part thereof */ 2 rest_of_record_ptr ptr; /* -> held data, if any */ dcl rest_of_record char (iad.input_switch.data_length) based (iad.input_switch.rest_of_record_ptr); %page; %include iocb; %page; %include iox_modes; %page; %include tty_read_status_info; %include tty_get_channel_info; %page; %include event_wait_info; %page; %include event_wait_channel; %page; %include imft_logical_record; %page; %include "_imft_cri"; %include "_imft_get_channel_names"; %page; %include "_imft_std_commands"; end imft_io_;  imft_mail_interface_.pl1 11/21/83 1214.2r w 11/21/83 1211.2 85329 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* Interim mechanism for IMFT to send mail/messages: should be eliminated when mail_system_ allows setting message access class and sending interactive messages */ /* Created: July 1982 by G. Palter as part of proper AIM support */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ imft_mail_interface_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl P_sender_name character (*) parameter; /* full name of sender (ie: foreign system) */ dcl P_destination character (*) parameter; /* user to receive the message (Person.Project) */ dcl P_message_type fixed binary parameter; /* type of message: ordinary or interactive */ dcl P_subject character (*) parameter; /* subject of mesage */ dcl P_text character (*) parameter; /* text of message */ dcl P_access_class bit (72) aligned parameter; /* access class of message */ dcl P_code fixed binary (35) parameter; /* Remaining declarations */ dcl message_text_buffer character (4 * sys_info$max_seg_size) based (message_text_buffer_ptr); dcl message_text character (message_text_lth) based (message_text_buffer_ptr); dcl message_text_lth fixed binary (21); dcl message_text_buffer_ptr pointer; dcl (ipc_priv_code, ring1_priv_code) fixed binary (35); dcl IMFT_MAIL_INTERFACE_ character (32) static options (constant) initial ("imft_mail_interface_"); dcl NOTIFY_MSG character (15) static options (constant) initial ("You have mail. "); dcl NL character (1) static options (constant) initial (" "); /* format: off */ dcl DAY_NAMES (7) character (32) static options (constant) initial ( "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday"); dcl MONTH_NAMES (12) character (32) static options (constant) initial ( "January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December"); dcl (error_table_$bad_subr_arg, error_table_$bigarg) fixed binary (35) external; /* format: on */ dcl sys_info$max_seg_size fixed binary (19) external; dcl decode_clock_value_$date_time entry (fixed binary (71), fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary (71), fixed binary, character (3), fixed binary (35)); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl send_mail_$access_class entry (character (*), character (*), pointer, bit (72) aligned, fixed binary (35)); dcl system_privilege_$ipc_priv_off entry (fixed binary (35)); dcl system_privilege_$ipc_priv_on entry (fixed binary (35)); dcl system_privilege_$ring1_priv_off entry (fixed binary (35)); dcl system_privilege_$ring1_priv_on entry (fixed binary (35)); dcl user_info_ entry (character (*), character (*)); dcl (addr, after, before, clock, convert, index, length, ltrim, null, rtrim, substr, unspec) builtin; dcl (cleanup, linkage_error) condition; %page; /* Deliver a messages to the specified user */ deliver_message: entry (P_sender_name, P_destination, P_message_type, P_subject, P_text, P_access_class, P_code); if (P_message_type ^= ORDINARY_DELIVERY) & (P_message_type ^= INTERACTIVE_DELIVERY) then do; P_code = error_table_$bad_subr_arg; return; end; if index (P_destination, ".") = 0 then do; /* only accepts Person.Project */ INVALID_DESTINATION_SYNTAX: P_code = error_table_$bad_subr_arg; return; end; if index (after (P_destination, "."), ".") ^= 0 then go to INVALID_DESTINATION_SYNTAX; if (before (P_destination, ".") = "") | (after (P_destination, ".") = "") then go to INVALID_DESTINATION_SYNTAX; /* Try to turn on ring-1 and IPC privileges: we might be sending down... */ ipc_priv_code, ring1_priv_code = -1; /* non-zero => we didn't turn privilege on */ message_text_buffer_ptr = null (); /* for cleanup handler */ on condition (cleanup) begin; if message_text_buffer_ptr ^= null () then call release_temp_segment_ (IMFT_MAIL_INTERFACE_, message_text_buffer_ptr, (0)); if ipc_priv_code = 0 then call system_privilege_$ipc_priv_off ((0)); if ring1_priv_code = 0 then call system_privilege_$ring1_priv_off ((0)); end; on condition (linkage_error) go to CANT_SET_PRIVILEGE; call system_privilege_$ring1_priv_on (ring1_priv_code); call system_privilege_$ipc_priv_on (ipc_priv_code); CANT_SET_PRIVILEGE: if P_message_type = ORDINARY_DELIVERY then do; /* Send a piece of mail: construct the header, send the mail, and send the notification */ call get_temp_segment_ (IMFT_MAIL_INTERFACE_, message_text_buffer_ptr, P_code); if P_code ^= 0 then go to RETURN_FROM_DELIVER_MESSAGE; call format_message (); unspec (send_mail_info) = ""b; send_mail_info.version = send_mail_info_version_2; send_mail_info.always_add = "1"b; send_mail_info.sent_from = P_sender_name; call send_mail_$access_class (P_destination, message_text, addr (send_mail_info), P_access_class, P_code); if P_code = 0 then do; /* got through OK */ send_mail_info.always_add = "0"b; /* notification is an express message */ send_mail_info.wakeup, send_mail_info.notify = "1"b; call send_mail_$access_class (P_destination, NOTIFY_MSG, addr (send_mail_info), P_access_class, (0)); end; end; else do; /* Interactive message: send it without any fancy headers */ unspec (send_mail_info) = ""b; send_mail_info.version = send_mail_info_version_2; send_mail_info.wakeup, /* normal interactive message */ send_mail_info.always_add = "1"b; send_mail_info.sent_from = P_sender_name; call send_mail_$access_class (P_destination, P_text, addr (send_mail_info), P_access_class, P_code); end; /* All done: cleanup; P_code is already set */ RETURN_FROM_DELIVER_MESSAGE: if message_text_buffer_ptr ^= null () then call release_temp_segment_ (IMFT_MAIL_INTERFACE_, message_text_buffer_ptr, (0)); if ipc_priv_code = 0 then call system_privilege_$ipc_priv_off ((0)); if ring1_priv_code = 0 then call system_privilege_$ring1_priv_off ((0)); return; %page; /* Formats a message by building the standard header */ format_message: procedure (); message_text_lth = 0; call add ("Date: "); call format_date (); call add (NL); call add ("From: "); call format_sender (); call add (NL); if P_subject ^= "" then do; call add ("Subject: "); call add_trimmed (P_subject); call add (NL); end; call add ("To: "); call add_trimmed (P_destination); call add (NL); call add (NL); call add_trimmed (P_text); return; %page; /* Internal to format_message: add text to the message */ add: procedure (p_text); text_lth = length (p_text); go to ACTUALLY_ADD_THE_TEXT; /* Internal to format_message: add text to the message but first remove trailing blanks */ add_trimmed: entry (p_text); text_lth = length (rtrim (p_text)); ACTUALLY_ADD_THE_TEXT: if message_text_lth + text_lth > length (message_text_buffer) then do; P_code = error_table_$bigarg; go to RETURN_FROM_DELIVER_MESSAGE; end; begin; dcl new_piece_of_message character (text_lth) unaligned defined (message_text_buffer) position (message_text_lth + 1); new_piece_of_message = substr (p_text, 1, text_lth); end; message_text_lth = message_text_lth + text_lth; return; dcl p_text character (*) parameter; dcl text_lth fixed binary (21); end add; %page; /* Internal to format_message: formats the current date/time */ format_date: procedure (); dcl four_digits picture "9999"; dcl two_digits picture "99"; dcl time_zone character (3); dcl (month, day_of_month, year, hour, minute, day_of_week) fixed binary; dcl code fixed binary (35); time_zone = ""; /* use default time zone */ call decode_clock_value_$date_time (clock (), month, day_of_month, year, hour, minute, (0), (0), day_of_week, time_zone, code); if code ^= 0 then /* shouldn't happen, but... */ call add ("unknown"); else do; call add_trimmed (DAY_NAMES (day_of_week)); call add (", "); call add (ltrim (convert (two_digits, day_of_month), "0")); call add (" "); call add_trimmed (MONTH_NAMES (month)); call add (" "); call add (convert (four_digits, year)); call add (" "); call add (convert (two_digits, hour)); call add (":"); call add (convert (two_digits, minute)); call add (" "); call add (time_zone); end; return; end format_date; %page; /* Internal to format_message: formats the sender */ format_sender: procedure (); dcl (my_person_id, my_project_id) character (32); call user_info_ (my_person_id, my_project_id); if P_sender_name ^= "" then do; call add_trimmed (P_sender_name); call add (" <"); end; call add_trimmed (my_person_id); call add ("."); call add_trimmed (my_project_id); if P_sender_name ^= "" then call add (">"); return; end format_sender; end format_message; %page; %include mlsys_deliver_info; %include send_mail_info; end imft_mail_interface_;  imft_pnt_interface_.pl1 12/05/84 1452.6r w 12/05/84 1004.0 24957 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* Interface between IMFT and the system PNT manager */ /* Note: All errors are translated into some code in imft_et_ to insure that the code can be properly transmitteded between the two systems */ /* Created: April 1982 by G. Palter */ /* Modified 1984-08-15 by E. Swenson for Version 2 PNTs. */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ imft_pnt_interface_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl P_system_id character (*) parameter; /* get_system_password: the system's Person_id */ dcl P_system_password character (8) aligned parameter; /* get_system_password: set to the system's password */ dcl P_user_id character (*) parameter; /* validate_personid: the user's Person_id */ dcl P_code fixed binary (35) parameter; /* Local copies of parameters */ dcl code fixed binary (35); /* Remaining declarations */ dcl system_password char (8); /* format: off */ dcl (imft_et_$cant_access_pnt, imft_et_$no_card_password, imft_et_$no_person_id) fixed binary (35) external; /* format: on */ dcl error_table_$id_not_found fixed binary (35) external; dcl error_table_$bad_password fixed bin (35) external static; dcl pnt_manager_$validate_entry entry (char (*), fixed bin (35)); dcl pnt_manager_$get_network_password entry (char (*), char (*), bit (1), fixed bin (35)); dcl addr builtin; /* */ /* Determines a system's card input password */ get_system_password: entry (P_system_id, P_system_password, P_code); call pnt_manager_$get_network_password (P_system_id, system_password, ("0"b), code); if code ^= 0 then if code = error_table_$bad_password then /* No network password */ code = imft_et_$no_card_password; /* the ID specified for a system must have one */ else if code = error_table_$id_not_found then code = imft_et_$no_person_id; else code = imft_et_$cant_access_pnt; /* the daemon doesn't have access to the PNT */ P_system_password = system_password; P_code = code; return; /* */ /* Validates that the given Person_id is in the PNT */ validate_personid: entry (P_user_id, P_code); call pnt_manager_$validate_entry (P_user_id, code); if code = 0 then ; /* found the given ID */ else if code = error_table_$id_not_found then code = imft_et_$no_person_id; else code = imft_et_$cant_access_pnt; /* the daemon doesn't have access to the PNT */ P_code = code; return; end imft_pnt_interface_;  imft_receive_object_.pl1 03/15/89 0843.5r w 03/15/89 0800.1 663453 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* Receive storage system objects from a remote Multics */ /* Created: October 1980 by G. Palter */ /* Modified: 28 February 1981 by G. Palter to validate user's access to parent directory and improve messages used to report incorrect access on the parent */ /* Modified: April 1982 by G. Palter to finish initial implementation */ /* Modified: July 1982 by G. Palter for true AIM support and to properly process I/O error abort control records */ /* Modified: March 1983 by Robert Coren to recognize local I/O errors and to not hide imft_et_$unknown_status_code */ /* Modified: March 1983 by Robert Coren to process requests for remote transfer */ /* Modified: July 1983 by Robert Coren to fix bug in call to ioa_$rsnnl */ /* Modified: August 1983 by Robert Coren for version 5 backup_control structure */ /* Modified: November 1983 by Robert Coren to turn on ring-1 privilege for pull requests in order to call queue_admin_$add_index with impunity */ /* Modified: 1984-10-11 BIM for mseg_message_info */ /****^ HISTORY COMMENTS: 1) change(88-06-30,Beattie), approve(88-08-01,MCR7948), audit(88-10-11,Farley), install(88-10-14,MR12.2-1165): a) Add support for extend and update operations. b) Add access check to support delete option in remote pulls. c) Change all access checks to look for explicit ACLs at all times. 2) change(88-11-10,Beattie), approve(88-08-01,PBF7948), audit(88-11-14,Farley), install(88-11-14,MR12.2-1214): Change declaration of local_request_number to match up with what is coming from request_descriptor structure to prevent size condtions. 3) change(88-11-16,Beattie), approve(88-08-01,PBF7948), audit(88-11-16,Farley), install(88-11-16,MR12.2-1217): Allow driver to access *.imft.acs through links in home directories without having status access by first calling hcs_$get_link_target to get actual pathname before checking access. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ imft_receive_object_: procedure (P_imft_driver_info_ptr, P_fis_info_ptr, P_code); imft_driver_info_ptr = P_imft_driver_info_ptr; fis_info_ptr = P_fis_info_ptr; P_code = 0; /* no errors yet */ foreign_system_name = rtrim (imft_driver_info.foreign_system.name); if fis_info.version ^= FIS_INFO_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if (fis_info.n_iocbs < 2) | (fis_info.n_iocbs > hbound (fis_info.iocbs, 1)) then do; P_code = error_table_$bad_arg; return; end; master_iocb_ptr = fis_info.iocbs (1); /* first switch is master terminal ... */ data_iocb_ptr = fis_info.iocbs (2); /* ... and second is where objects arrives */ if (master_iocb_ptr = null ()) | (data_iocb_ptr = null ()) then do; P_code = error_table_$bad_arg; return; end; system_area_ptr = get_system_free_area_ (); /** for determining access */ my_group_id = get_group_id_ (); /* Person.Project.Tag */ /* strip tag */ my_user_id = substr (my_group_id, 1, length (rtrim (my_group_id)) - 2); current_ring = get_ring_ (); /* One time initialization */ if first_call then do; errfile_dname = get_pdir_ (); /* place for reload's error files */ errfile_ename = "IMFT." || unique_chars_ (""b); errfile_pathname = pathname_ (errfile_dname, errfile_ename); call hcs_$make_seg (errfile_dname, errfile_ename, "", RW_ACCESS_BIN, errfile_ptr, code); if errfile_ptr = null () then do; /* shouldn't happen, but... */ call iodd_msg_ (ERROR, MASTER, code, IMFT_RECEIVE_OBJECT_, "Creating ^a as error file for notifications.", errfile_pathname); P_code = code; return; end; call hcs_$terminate_noname (errfile_ptr, ignore_code); branch_info.version = create_branch_version_2; /* initialize branch info structure */ branch_info.dir_sw = "1"b; branch_info.copy_sw = "0"b; branch_info.chase_sw = "0"b; branch_info.priv_upgrade_sw = "0"b; branch_info.parent_ac_sw = "1"b; branch_info.mbz1 = ""b; branch_info.mode = SMA_ACCESS; branch_info.mbz2 = ""b; branch_info.rings (1), branch_info.rings (2), branch_info.rings (3) = 7; branch_info.userid = my_group_id; branch_info.bitcnt = 0; branch_info.quota = 0; branch_info.access_class = get_authorization_ (); branch_info.dir_quota = 0; temp_ename = "IMFT_dir." || unique_chars_ (""b); temp_dname = pathname_ (errfile_dname, temp_ename); call hcs_$create_branch_ (errfile_dname, temp_ename, addr (branch_info), code); if code ^= 0 then do; call iodd_msg_ (ERROR, MASTER, code, IMFT_RECEIVE_OBJECT_, "Creating holding directory for extend and update file operations."); P_code = code; return; end; first_call = "0"b; /* all set */ end; /* Setup for operation */ acl_ptr, errfile_ptr = null (); /* keep cleanup handler happy */ errfile_attached, object_in_progress = "0"b; on condition (cleanup) call cleanup_handler (); /* Main processing loop: Accept objects from the remote system indefintely or until input is available on the master console. When input is available from the master, control returns to the caller when between objects to permit driver command processing */ do while ("1"b); call imft_find_input_switch_ (fis_info_ptr, "1"b, source, code); if code ^= 0 then do; call iodd_msg_ (ERROR, MASTER, code, IMFT_RECEIVE_OBJECT_, "Waiting for input from master or remote.") ; P_code = code; go to RETURN_FROM_RECEIVE_OBJECT; end; if (source = 1) then /* input from master console */ go to RETURN_FROM_RECEIVE_OBJECT; /* Input is available from remote Multics: check for a BOF command */ object_in_progress = "0"b; /* haven't started yet */ local_icri.version = ICRI_VERSION_1; local_icri.timeout = 5 * ONE_MINUTE; /* give it a chance to be read */ local_icri.record_ptr = addr (input_buffer); local_icri.record_max_lth = length (input_buffer); call iox_$control (data_iocb_ptr, "read_command_record", addr (local_icri), code); if code ^= 0 then call io_error (code, "Attempting to read from " || foreign_system_name || "."); if (local_icri.record_type = IMFT_SYNC1) | (local_icri.record_type = IMFT_SYNC2) then signal condition (imft_resynchronize_driver_); else if local_icri.record_type = IMFT_LOGOUT then signal condition (imft_remote_logout_); else if local_icri.record_type ^= IMFT_BOF & local_icri.record_type ^= IMFT_REMOTE_REQUEST then do; call iodd_msg_ (NORMAL, MASTER, NO_ERROR, IMFT_RECEIVE_OBJECT_, "Unexpected command code ^d from ^a.", local_icri.record_type, foreign_system_name); P_code = error_table_$fatal_error; /* make driver reinitialize */ go to RETURN_FROM_RECEIVE_OBJECT; end; local_bof_reply.abort_request = "0"b; /* assume everything is OK */ local_bof_reply.abort_message = ""; acl_count = 2; /* one entry each for driver and user */ allocate general_acl in (system_area) set (acl_ptr); general_acl.version = GENERAL_ACL_VERSION_1; general_acl.count = acl_count; general_acl (DRIVER_ACL_IDX).access_name = rtrim (my_user_id) || ".*"; imft_chk_acl.version = IMFT_CHECK_ACL_VERSION_1; imft_chk_acl.foreign_sys_name = foreign_system_name; imft_chk_acl.gen_acl_ptr = acl_ptr; imft_chk_acl.sys_auth_ceiling = imft_driver_info.local_system.access_ceiling; imft_chk_acl.sys_auth_floor = imft_driver_info.local_system.access_floor; object_in_progress = "1"b; /* in case of QUITs or other failures */ %page; if local_icri.record_type = IMFT_BOF then do; /**** Object to be sent from other system. */ local_bof_command = addr (input_buffer) -> bof_command; local_request_number, local_bof_reply.request_number = local_bof_command.request_number; /* Determine resting place of the object, the user to notify, log the BOF command, inform the user that something is coming, and validate that the driver and user have proper access */ if local_bof_command.foreign_path_given then do; local_dirname = local_bof_command.foreign_dirname; local_entname = local_bof_command.foreign_ename; local_full_pathname = pathname_ (local_dirname, local_entname); foreign_full_pathname = pathname_ (local_bof_command.local_dirname, local_bof_command.local_ename); end; else do; local_dirname = local_bof_command.local_dirname; local_entname = local_bof_command.local_ename; local_full_pathname, foreign_full_pathname = pathname_ (local_dirname, local_entname); end; if local_bof_command.foreign_user_given then mail_destination = local_bof_command.foreign_user; else mail_destination = local_bof_command.local_user; foreign_user_id = rtrim (local_bof_command.local_user); local_user_id = rtrim (mail_destination); imft_chk_acl.user_auth = local_bof_command.local_user_authorization; call translate_aim_attributes_ (imft_driver_info.foreign_system.aim_attributes_ptr, local_bof_command.local_user_authorization, imft_driver_info.local_system.aim_attributes_ptr, mail_access_class, code); if code ^= 0 then /* submitter authorization is too high ... */ mail_access_class = imft_driver_info.local_system.access_ceiling; call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "Request ^d ^a input q^d: receive^[ extension to^]^[ update to^] ^a ^a^/^2xfor ^a^[ from ^a^;^s^]^[^/^2xoriginally ^a^]", local_bof_command.request_number, foreign_system_name, local_bof_command.queue, local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, mail_destination, local_bof_command.foreign_user_given, local_bof_command.local_user, local_bof_command.foreign_path_given, foreign_full_pathname); local_personid = before (mail_destination, "."); call imft_pnt_interface_$validate_personid (local_personid, code); if code ^= 0 then call reject_request (code, "Validating user name """ || rtrim (local_personid) || """."); call translate_aim_attributes_ (imft_driver_info.foreign_system.aim_attributes_ptr, local_bof_command.object_access_class, imft_driver_info.local_system.aim_attributes_ptr, local_bof_command.object_access_class, code); if code ^= 0 then do; call convert_aim_attributes_ (local_bof_command.object_access_class, octal_string); call reject_request (code, "Attempting to translate access class (" || rtrim (octal_string) || ") from " || foreign_system_name || "."); end; call validate_access (); /* will abort if not OK */ if local_bof_command.notify then call notify_user ( "Beginning reception of^[ extension to^]^[ update to^] ^a ^a from ^a (queue ^d).", local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name, local_bof_command.queue); /* If control reaches here, as much validation of the request has been performed as possible without actually invoking backup_load_: Inform the other system that it may send the object */ local_icri.version = ICRI_VERSION_1; local_icri.timeout = 5 * ONE_MINUTE; /* give the other system a decent chance */ local_icri.record_type = IMFT_BOF; /* this is a reply to their BOF command */ local_icri.record_ptr = addr (local_bof_reply); local_icri.record_lth = 4 * currentsize (local_bof_reply); call iox_$control (data_iocb_ptr, "write_reply_record", addr (local_icri), code); if code ^= 0 then call io_error (code, "Attempting to reply to " || foreign_system_name || "."); /* Prepare to invoke backup_load_: construct description of reload and terminate the backup system to cleanup from last use in this process (if any) */ static_backup_control.version = BACKUP_CONTROL_VERSION_5; static_backup_control.tape_entry = nulle; string (static_backup_control.options) = ""b; static_backup_control.debug_sw = "1"b; static_backup_control.error_file = "1"b; static_backup_control.first = "1"b; static_backup_control.allow_dir_overwrite = "1"b; static_backup_control.preattached = "1"b; /* we supply the I/O switch */ static_backup_control.data_iocb = data_iocb_ptr; static_backup_control.restore_access_class = "1"b; /* restore the AIM access class even though not privileged */ static_backup_control.enforce_minimum_ring = "1"b; static_backup_control.minimum_ring = acs_write_bracket; /* don't create anything lower than the ACS segment's write bracket which should reflect local user's normal ring of execution */ static_backup_control.translate_access_class = "1"b; static_backup_control.source_attributes_ptr = imft_driver_info.foreign_system.aim_attributes_ptr; static_backup_control.target_attributes_ptr = imft_driver_info.local_system.aim_attributes_ptr; /* translate foreign system's AIM attributes to our own */ static_backup_control.request_count = 1;/* one and only one object to load */ static_backup_control.object.path = foreign_full_pathname; if local_bof_command.extend | local_bof_command.update then static_backup_control.object.new_path = pathname_ (temp_dname, local_entname); else if local_bof_command.foreign_path_given then /* user requested it be put somewhere else */ static_backup_control.object.new_path = local_full_pathname; else static_backup_control.object.new_path = ""; string (static_backup_control.object.switches) = ""b; static_backup_control.object.no_primary_sw = "1"b; if local_bof_command.object_type = MSF then /* always flush old subtree if present */ static_backup_control.object.trim_sw = "1"b; else static_backup_control.object.trim_sw = (local_bof_command.directory_creation_mode = REPLACE_DIRECTORIES); call term_$refname ("backup_load_", ignore_code); call term_$refname ("backup_map_", ignore_code); call term_$refname ("bk_ss_", ignore_code); call ios_$attach ("err_file", "file", errfile_pathname, "w", ios_status); if ios_status.code ^= 0 then call abort_reception (ios_status.code, "Setting up backup error file."); errfile_attached = "1"b; /* go it */ /* Perform the reload: establish a handler in case anything went wrong during transmission and invoke backup_load_ */ on condition (imft_read_abort_) call analyze_read_abort; call backup_load_ (addr (static_backup_control), code); RETURN_FROM_BACKUP_LOAD: /* backup_load_ will read the EOF record */ call analyze_backup_results (code); if ^backup_errors_detected then /* reload occurred without any troubles ... */ if local_bof_command.extend | local_bof_command.update then do; string (cpo.copy_items) = ""b; cpo.version = COPY_OPTIONS_VERSION_1; cpo.caller_name = IMFT_RECEIVE_OBJECT_; cpo.copy_items.entry_bound = "1"b; string (cpo.flags) = ""b; cpo.flags.delete = "1"b; cpo.copy_items.extend = local_bof_command.extend; cpo.copy_items.update = local_bof_command.update; cpo.flags.raw = "1"b; cpo.source_dir = temp_dname; cpo.source_name = local_entname; cpo.target_dir = local_dirname; cpo.target_name = local_entname; on sub_error_ call copy_sub_err_handler (); call copy_ (addr (cpo)); revert sub_error_; end; COPY_OPERATION_FINISHED: if ^backup_errors_detected then /* reload occurred without any troubles ... */ if local_bof_command.notify then call notify_user ( "Received^[ extension to^]^[ update to^] ^a ^a without^[ further^] errors from ^a (queue ^d).", local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_backup_errors, foreign_system_name, local_bof_command.queue); if ^imft_driver_info.old_version then do; /* other end is expecting eof_reply to confirm */ /* successful reception */ local_eof_reply.request_number = local_request_number; local_eof_reply.error = backup_errors_detected; local_icri.version = ICRI_VERSION_1; local_icri.timeout = 5 * ONE_MINUTE; local_icri.record_type = IMFT_EOF; local_icri.record_ptr = addr (local_eof_reply); local_icri.record_lth = 4 * currentsize (local_eof_reply); call iox_$control (data_iocb_ptr, "write_reply_record", addr (local_icri), code); if code ^= 0 then call io_error (code, "Attempting to reply to " || foreign_system_name || "."); end; if backup_errors_detected | foreign_backup_errors then call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2xNon-fatal errors in transfer detected by ^[^a^;^s^]^[ and ^]^[^a^]", foreign_backup_errors, foreign_system_name, foreign_backup_errors & backup_errors_detected, backup_errors_detected, imft_driver_info.local_system.name); call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2xReceived request ^d.", local_bof_command.request_number); end; /* if sending to other system */ %page; /**** Request to queue transfers from here to the other system. */ else do; local_rr = addr (input_buffer) -> remote_request; local_request_number, local_bof_reply.request_number = local_rr.request_number; local_dirname = local_rr.dirname; local_starname = local_rr.ename; local_full_pathname = pathname_ (local_dirname, local_starname); if local_rr.foreign_path_given then foreign_equalname = pathname_ (local_rr.foreign_dirname, local_rr.foreign_ename); else foreign_equalname = local_full_pathname; if local_rr.foreign_user_given then mail_destination = local_rr.foreign_user; else mail_destination = local_rr.local_user; foreign_user_id = rtrim (local_rr.local_user); local_user_id = rtrim (mail_destination); general_acl (USER_ACL_IDX).access_name = local_user_id || ".*"; call translate_aim_attributes_ (imft_driver_info.foreign_system.aim_attributes_ptr, local_rr.local_user_authorization, imft_driver_info.local_system.aim_attributes_ptr, mail_access_class, code); if code ^= 0 then /* submitter authorization is too high ... */ mail_access_class = imft_driver_info.local_system.access_ceiling; if ^imft_driver_info.remote_request_allowed /* this site doesn't permit it */ then call reject_request (NO_ERROR, foreign_system_name || " does not have permission to request transfers."); local_personid = before (mail_destination, "."); call imft_pnt_interface_$validate_personid (local_personid, code); if code ^= 0 then call reject_request (code, "Validating user name """ || rtrim (local_personid) || """."); call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "Request ^d ^a input q^d: transmit^[ extension^]^[ update^] ^a^/^2xfrom ^a^[ for ^a^;^s^]^[^/^2xas ^a^]", local_request_number, foreign_system_name, local_rr.queue, local_rr.extend, local_rr.update, local_full_pathname, mail_destination, local_rr.foreign_user_given, local_rr.local_user, local_rr.foreign_path_given, foreign_equalname); call validate_acs (R_ACCESS); user_ring = max (local_rr.local_user_ring, acs_write_bracket); call submit_request; /* if we return to here, we submitted the request, or part of it, anyway, so tell the other system */ local_icri.version = ICRI_VERSION_1; local_icri.timeout = 5 * ONE_MINUTE; /* give the other system a decent chance */ local_icri.record_type = IMFT_BOF; /* this is a reply to their BOF command */ local_icri.record_ptr = addr (local_bof_reply); local_icri.record_lth = 4 * currentsize (local_bof_reply); call ioa_$rsnnl ("Queued ^d request^[^;s^] on ^a for request ^d^[ with ^d error^[^;s^]^].", local_bof_reply.abort_message, ignore_fb21, n_submitted, (n_submitted = 1), imft_driver_info.local_system.name, local_request_number, (n_not_submitted > 0), n_not_submitted, (n_not_submitted = 1)); call iox_$control (data_iocb_ptr, "write_reply_record", addr (local_icri), code); if code ^= 0 then call io_error (code, "Attempting to reply to " || foreign_system_name || "."); call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2xQueued ^d request^[^;s^] for request ^d^[ with ^d error^[^;s^]^].", n_submitted, (n_submitted = 1), local_request_number, (n_not_submitted > 0), n_not_submitted, (n_not_submitted = 1)); end; /* if queueing transfers from here to other system */ object_in_progress = "0"b; /* all done with this one */ WAIT_FOR_NEXT_OBJECT: end; /* do while ("1"b) */ RETURN_FROM_RECEIVE_OBJECT: call cleanup_handler (); return; %page; /* Handler for imft_read_abort_: This condition is raised during reading of backup records if transmission was prematurely terminated at the remote system */ analyze_read_abort: procedure (); local_icri.version = ICRI_VERSION_1; local_icri.timeout = 5 * ONE_MINUTE; /* give the remote system sometime */ local_icri.record_ptr = addr (input_buffer); local_icri.record_max_lth = length (input_buffer); call iox_$control (data_iocb_ptr, "get_abort_info", addr (local_icri), code); if code ^= 0 then call io_error (code, "Attempting to read from " || foreign_system_name || "."); if (local_icri.record_type = IMFT_SYNC1) | (local_icri.record_type = IMFT_SYNC2) then do; call notify_user ("Request for ^a deferred: ^a requested driver to reinitialize.", local_full_pathname, foreign_system_name); signal condition (imft_resynchronize_driver_); end; else if local_icri.record_type = IMFT_LOGOUT then do; call notify_user ("Request for ^a deferred: ^a's output driver disconnected.", local_full_pathname, foreign_system_name); signal condition (imft_remote_logout_); end; else if local_icri.record_type = IMFT_EOF then do;/* backup_load_ will keep reading after object is loaded: */ /* the EOF record after the object is trapped here */ eof_command_ptr = local_icri.record_ptr; go to RETURN_FROM_BACKUP_LOAD; end; else if local_icri.record_type = IMFT_ABORT then do; abort_command_ptr = local_icri.record_ptr; if abort_command.reason = IMFT_ABORT_IO_ERROR | abort_command.reason = IMFT_ABORT_LOCAL_IO_ERROR then do; if abort_command.reason = IMFT_ABORT_IO_ERROR /* came from foreign system */ then abort_command.code = imft_convert_status_code_$decode (abort_command.code); call io_error (abort_command.code, "Attempting to read from " || foreign_system_name || "."); end; else if abort_command.reason = IMFT_ABORT_ABORTED then call abort_reception (NO_ERROR, foreign_system_name || " terminated transmission prematurely."); else if abort_command.reason = IMFT_ABORT_RESTARTED then call abort_reception (NO_ERROR, "Operator at " || foreign_system_name || " restarted the request."); else if (abort_command.reason = IMFT_ABORT_DEFERRED) | (abort_command.reason = IMFT_ABORT_SAVED) then call abort_reception (NO_ERROR, "Operator at " || foreign_system_name || " deferred transmission until a later time."); else if abort_command.reason = IMFT_ABORT_CANCELLED then call abort_reception (NO_ERROR, "Operator at " || foreign_system_name || " cancelled transmission."); else call abort_reception (NO_ERROR, foreign_system_name || " terminated transmission for an unknown reason."); end; else do; call iodd_msg_ (NORMAL, MASTER, NO_ERROR, IMFT_RECEIVE_OBJECT_, "Unexpected command code ^d from ^a.", local_icri.record_type, foreign_system_name); P_code = error_table_$fatal_error; /* make driver reinitialize */ go to RETURN_FROM_RECEIVE_OBJECT; end; end analyze_read_abort; %page; /* Cleanup before returning to caller */ cleanup_handler: procedure (); if acl_ptr ^= null () then do; free general_acl in (system_area); acl_ptr = null (); end; if errfile_ptr ^= null () then do; call hcs_$terminate_noname (errfile_ptr, ignore_code); errfile_ptr = null (); end; if errfile_attached then do; call ios_$detach ("err_file", "", "", ios_status); call hcs_$truncate_file (errfile_dname, errfile_ename, 0, ignore_code); call hcs_$set_bc (errfile_dname, errfile_ename, 0, ignore_code); errfile_attached = "0"b; end; if object_in_progress then do; call iodd_msg_ (NORMAL, MASTER, NO_ERROR, IMFT_RECEIVE_OBJECT_, "Processing of request ^d terminated.", local_request_number); object_in_progress = "0"b; end; return; end cleanup_handler; %page; copy_sub_err_handler: procedure; dcl 1 ci aligned like condition_info; dcl local_error_message character (1024); call find_condition_info_ (null (), addr (ci), ignore_code); sub_error_info_ptr = ci.info_ptr; if sub_error_info.name ^= "copy_" then do; CONTINUE_TO_SIGNAL: call continue_to_signal_ (ignore_code); goto END_COPY_HANDLER; end; else if sub_error_info.info_ptr = null then goto CONTINUE_TO_SIGNAL; else if copy_error_info.copy_options_ptr ^= addr (cpo) then goto CONTINUE_TO_SIGNAL; code = sub_error_info.status_code; if code ^= 0 then do; if code = error_table_$unsupported_operation & copy_error_info.operation = "entry bound" then go to COPY_OPERATION_FINISHED; backup_errors_detected = "1"b; call convert_status_code_ (code, shortinfo, code_message); call ioa_$rsnnl ("Error occured in extend/update operation:^[^s^; ^a^]^/(^a)", local_error_message, ignore_fb21, (sub_error_info.info_string = ""), sub_error_info.info_string, code_message); call notify_user (local_error_message); end; go to COPY_OPERATION_FINISHED; END_COPY_HANDLER: end copy_sub_err_handler; %page; /****^ Validates access to receive a transfer request: Let TPerson.TProj be the user who is to receive the file/subtree, SPerson.SProj be the user (on the other system) who is sending the file/subtree, MPerson.MProj be the user who is running the daemon, and let TDir be the directory into which the file/subtree will be placed. Then: (1) SPerson.SProj must have explicit write access to the segment: >udd>TProj>TPerson>SSite.imft.acs where SSite is the name of the foreign system (the foreign_system keyword in the I/O daemon tables), (2) TPerson.TProj and MPerson.MProj must have explicit "sma" access to TDir, and (3) the access class of DIR must be equal to the access class of the file/subtree from the other system. To perform these checks, MPerson.MProj requires "s" access to the parent of TDir and to >udd>TProj>TPerson. The user's access to the directory is checked using the highest value of the following 3 items; (1) write bracket of the user's ACS segment on local system as the user's ring of execution. (2) the foreign user ring of execution. (3) driver ring of execution. */ validate_access: procedure () options (non_quick); /* because it has lots of automatic storage */ dcl dir_access_class bit (72) aligned; dcl dir_access_class_text character (256); dcl local_error_message character (1024); dcl local_pathname character (168); dcl object_access_class_text character (256); dcl parent_dirname character (168); dcl parent_ename character (32); dcl transfer_ring fixed binary (3); call validate_acs (W_ACCESS); /* check access on ACS */ transfer_ring = max (local_bof_command.local_user_ring, acs_write_bracket); if local_dirname = ">" then /* can't transfer to the root */ call reject_request (NO_ERROR, "IMFT can not create branches under the root."); %page; /**** Both driver and user must have explicit SMA access to parent directory */ call expand_pathname_ (local_dirname, parent_dirname, parent_ename, ignore_code); imft_chk_acl.dirname = parent_dirname; imft_chk_acl.ename = parent_ename; imft_chk_acl.dir_access = SMA_ACCESS; imft_chk_acl.seg_access = RW_ACCESS; imft_chk_acl.check_aim = "0"b; /* check_object_acl AIM check is not right for parent dir */ imft_chk_acl.effective_ring = transfer_ring; imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX; /* by default, error is driver's */ general_acl (USER_ACL_IDX).access_name = local_user_id || ".*"; call imft_util_$check_object_acl (addr (imft_chk_acl), code); if code = 0 then code = imft_chk_acl.error_code; if code ^= 0 then do; if code = error_table_$unimplemented_version then call fatal_ica_error (); call set_va_dir_sma_error_message (imft_chk_acl.bad_acl_idx); call reject_request (code, local_error_message); end; /* if code ^= 0 */ code = 0; do idx = 1 to hbound (general_acl.entries, 1); if general_acl (idx).status_code ^= 0 then do; code = general_acl (idx).status_code; call convert_status_code_ (code, shortinfo, code_message); call set_va_dir_sma_error_message (idx); call notify_user (REQ_TERMED_STR, code ^= 0, code_message, local_error_message, local_dirname); end; end; if code ^= 0 then call reject_request_no_notify (NO_ERROR, "Insufficient driver/user access to parent directory to receive object."); /**** Check AIM of parent directory. */ call hcs_$get_access_class ((parent_dirname), (parent_ename), dir_access_class, code); if code ^= 0 then call reject_request (code, "Attempting to determine access class of parent directory to object."); if ^aim_check_$equal (dir_access_class, local_bof_command.object_access_class) then do; dir_access_class_text, object_access_class_text = ""; call convert_authorization_$to_string_short (dir_access_class, dir_access_class_text, ignore_code); call convert_authorization_$to_string_short (local_bof_command.object_access_class, object_access_class_text, ignore_code); call ioa_$rsnnl ( "Access class of ^a (^[^a^;^ssystem_low^]) must be equal to access class of object on ^a (^[^a^;^ssystem_low^]).", local_error_message, ignore_fb21, local_dirname, (dir_access_class_text ^= ""), dir_access_class_text, foreign_system_name, (object_access_class_text ^= ""), object_access_class_text); call reject_request (error_table_$ai_restricted, local_error_message); end; %page; if local_bof_command.extend | local_bof_command.update then do; /**** Object must already exist and have explicit ACL entries of RW for both driver and user. */ local_pathname = pathname_ (local_dirname, local_entname); imft_chk_acl.dirname = local_dirname; imft_chk_acl.ename = local_entname; imft_chk_acl.dir_access = SMA_ACCESS; imft_chk_acl.seg_access = RW_ACCESS; imft_chk_acl.check_aim = "1"b; imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX; /* by default, error is driver's */ general_acl (USER_ACL_IDX).access_name = local_user_id || ".*"; call imft_util_$check_object_acl (addr (imft_chk_acl), code); if code = 0 then code = imft_chk_acl.error_code; if code ^= 0 then do; if code = error_table_$unimplemented_version then call fatal_ica_error (); call reject_request (NO_ERROR, (imft_chk_acl (imft_chk_acl.bad_acl_idx).error_message)); end; code = 0; do idx = 1 to hbound (general_acl.entries, 1); if general_acl (idx).status_code ^= 0 then do; code = general_acl (idx).status_code; call notify_user (REQ_TERMED_STR, "0"b, code_message, imft_chk_acl (idx).error_message, local_pathname); /* code_message is already in .error_message */ end; end; if code ^= 0 then call reject_request_no_notify (NO_ERROR, "Insufficient driver/user access to extend or update object."); if ^(imft_chk_acl.type = ENTRY_TYPE_SEGMENT | imft_chk_acl.type = ENTRY_TYPE_MSF) then do; if index (imft_chk_acl.type, "-") = 1 then local_type = substr (imft_chk_acl.type, 2); else local_type = imft_chk_acl.type; call ioa_$rsnnl ("Can only ^[extend^]^[update^] with segments or MSFs, not with ^a type object.", local_error_message, ignore_fb21, local_bof_command.extend, local_bof_command.update, local_type) ; call reject_request (NO_ERROR, local_error_message); end; end; /* if extend or update */ return; /* passes */ %page; set_va_dir_sma_error_message: proc (p_idx); dcl p_idx fixed binary parameter; if code = error_table_$moderr | code = error_table_$user_not_found then call ioa_$rsnnl ( "^[Driver^;User^] (^a) must have an explicit ACL entry of SMA to parent directory of object to be received.", local_error_message, ignore_fb21, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name, local_pathname); else call ioa_$rsnnl ( "Unable to determine ^a's and ^a's access to parent directory of object to be received.", local_error_message, ignore_fb21, local_user_id, my_user_id); end set_va_dir_sma_error_message; end validate_access; %page; /* Check for the existence of the ACS described in introductory comment to validate_access, and ensure that the foreign user has the appropriate access (W for transferring objects to this system, or R for requesting that they be transferred to SSite). */ validate_acs: procedure (access_required); dcl access_required bit (3) parameter; dcl link_dirname character (168); dcl link_ename character (32); dcl local_dirname character (168); dcl local_ename character (32); dcl local_error_message character (1024); dcl local_pathname character (168); local_dirname, imft_chk_acl.dirname = ">udd>" || after (local_user_id, ".") || ">" || before (local_user_id, "."); local_ename, imft_chk_acl.ename = foreign_system_name || ".imft.acs"; local_pathname = pathname_ (local_dirname, local_ename); /* ACS path could be a link in "home" directory to which */ /* daemon doesn't even have status access, */ /* find actual path */ call hcs_$get_link_target (local_dirname, local_ename, link_dirname, link_ename, code); if code = 0 | code = error_table_$noentry then do; /** previous call could have changed pathname */ imft_chk_acl.dirname = link_dirname; imft_chk_acl.ename = link_ename; local_pathname = pathname_ (link_dirname, link_ename); end; if code ^= 0 then go to VALIDATE_ACS_ERROR; imft_chk_acl.dir_access = S_ACCESS; imft_chk_acl.seg_access = access_required; imft_chk_acl.check_aim = "0"b; imft_chk_acl.effective_ring = 0; /* we want to know what it is without getting an error */ imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX; /* by default, error is driver's */ general_acl (USER_ACL_IDX).access_name = foreign_user_id || ".*"; call imft_util_$check_object_acl (addr (imft_chk_acl), code); if code = 0 then code = imft_chk_acl.error_code; if code ^= 0 then do; if code = error_table_$unimplemented_version then call fatal_ica_error (); VALIDATE_ACS_ERROR: call set_acs_error_message (); call reject_request (code, local_error_message); end; if general_acl (USER_ACL_IDX).status_code ^= 0 then do; code = general_acl (USER_ACL_IDX).status_code; call set_acs_error_message (); /* code can be set to 0 in this call */ call reject_request (code, local_error_message); end; acs_write_bracket = max (imft_chk_acl.object_ring, current_ring); /* restrict transfers to user's probable ring of */ /* execution unless we operate in a higher ring */ return; %page; /**** Support routine for validate_acs to generate an applicable error message. */ set_acs_error_message: proc; if code = error_table_$noentry then do; call ioa_$rsnnl ("^a has not established an ACS segment in ^a to control transfers ^[from^;to^] ^a.", local_error_message, ignore_fb21, local_user_id, imft_chk_acl.dirname, (access_required = W_ACCESS), foreign_system_name); code = 0; /* no need to include the error_table_ message */ end; else if code = error_table_$moderr | code = error_table_$user_not_found then call ioa_$rsnnl ("^a has not given ^a permission to transfer files ^[from^;to^] ^a ^[to^;from^] ^a.", local_error_message, ignore_fb21, local_user_id, foreign_user_id, (access_required = W_ACCESS), foreign_system_name, (access_required = W_ACCESS), imft_driver_info.local_system.name); else call ioa_$rsnnl ("Attempting to determine ^a's access to ^a.", local_error_message, ignore_fb21, foreign_user_id, local_pathname); end set_acs_error_message; end validate_acs; %page; /* Submit one or more requests for transfer to the foreign system as specified by the starname given in a request for remote transfer. This code is essentially lifted from enter_imft_request */ submit_request: procedure; dcl queue_index fixed bin; dcl request_type character (24); dcl transmit_driver_id character (32); dcl queue_ename character (32); dcl local_error_message character (1024); dcl queue_picture picture "9"; dcl access_mode bit (36) aligned; dcl queue_mode bit (36) aligned; dcl chase_control bit (2); dcl have_starname bit (1); dcl submitted_a_request bit (1); dcl reported_error bit (1); dcl reported_dir_sma_warning bit (1); dcl entry_idx fixed bin; dcl priv_code fixed bin (35); dcl 1 local_ft_request aligned like ft_request; queue_index = 0; /* for cleanup handler */ priv_code = -1; /* so it won't look like we turned it on */ star_entry_ptr, star_names_ptr = null (); on cleanup begin; if star_names_ptr ^= null () then do; free star_names in (system_area); star_names_ptr = null (); end; if star_entry_ptr ^= null () then do; free star_entries in (system_area); star_entry_ptr = null (); end; if queue_index ^= 0 then do; call message_segment_$close (queue_index, ignore_code); queue_index = 0; end; if priv_code = 0 /* we turned ring 1 privilege on */ then call system_privilege_$ring1_priv_off (ignore_code); end; local_user_access_id = local_user_id || ".*"; request_type = "To_" || foreign_system_name; queue_ename = rtrim (request_type) || "_" || convert (queue_picture, local_rr.queue) || ".ms"; /* turn on ring 1 privilege in preparation for call to queue_admin_$add_index */ on linkage_error ; /* if we don't have access to the gate, we'll risk it */ call system_privilege_$ring1_priv_on (priv_code); /* sets code to 0 iff privilege was off before and */ revert linkage_error; /* we turned it on */ call message_segment_$open (imft_data_$queue_dirname, queue_ename, queue_index, code); if code ^= 0 then call reject_request (code, "Opening " || pathname_ (imft_data_$queue_dirname, queue_ename)); call hcs_$get_user_access_modes (imft_data_$queue_dirname, queue_ename, local_user_access_id, (user_ring), access_mode, queue_mode, code); if code ^= 0 then call reject_request (code, "Could not determine access to " || pathname_ (imft_data_$queue_dirname, queue_ename)); if (queue_mode & A_EXTENDED_ACCESS) ^= A_EXTENDED_ACCESS /* not enough access at all */ then call reject_request (NO_ERROR, "User has insufficient access to " || rtrim (request_type) || " queue " || convert (queue_picture, local_rr.queue)); call iod_info_$driver_access_name (request_type, transmit_driver_id, code); if code ^= 0 then do; call ioa_$rsnnl ("Receiving driver attempting to determine transmiting driver ident on ^a system.", local_error_message, ignore_fb21, imft_driver_info.local_system.name); call reject_request (code, local_error_message); end; general_acl (DRIVER_ACL_IDX).access_name = transmit_driver_id; /* Fill in constant portion of the ft_request */ unspec (local_ft_request) = ""b; local_ft_request.header.hdr_version = queue_msg_hdr_version_1; local_ft_request.header.message_type = FT_MESSAGE_TYPE; local_ft_request.header.notify = local_rr.notify; local_ft_request.header.orig_queue = local_rr.queue; local_ft_request.header.std_length = currentsize (local_ft_request); local_ft_request.delete = local_rr.delete; local_ft_request.extend = local_rr.extend; local_ft_request.update = local_rr.update; local_ft_request.version = FT_REQUEST_VERSION_1; if foreign_user_id ^= local_user_id then do; /* foreign user is different from local user */ local_ft_request.foreign_user = foreign_user_id; local_ft_request.foreign_user_given = "1"b; end; local_ft_request.foreign_path_given = local_rr.foreign_path_given; chase_control = local_rr.chase_control; n_submitted = 0; n_not_submitted = 0; call check_star_name_$entry (local_starname, code); have_starname = (code ^= 0); reported_dir_sma_warning = "0"b; /* SMA access warning is to be reported once per request */ if have_starname then do; /* more than one object */ star_entry_ptr, star_names_ptr = null (); submitted_a_request, reported_error = "0"b; if chase_control = ALWAYS_CHASE then call hcs_$star_ (local_dirname, local_starname, star_ALL_ENTRIES, system_area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); else call hcs_$star_ (local_dirname, local_starname, star_BRANCHES_ONLY, system_area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then call reject_request (code, "Attempting to process star names."); do entry_idx = 1 to star_entry_count; call process_single_request (local_dirname, star_names (star_entries (entry_idx).nindex)); PROCESS_NEXT_STAR_ENTRY: end; free star_names in (system_area); free star_entries in (system_area); star_entry_ptr, star_names_ptr = null (); if ^submitted_a_request then if reported_error then call reject_request_no_notify (NO_ERROR, NO_OBJ_FND_SATISFY_REQ_STR); else call reject_request (NO_ERROR, NO_OBJ_FND_SATISFY_REQ_STR); end; else call process_single_request (local_dirname, local_starname); call message_segment_$close (queue_index, ignore_code); if priv_code = 0 /* if we turned ring-1 privilege on */ then call system_privilege_$ring1_priv_off (ignore_code); return; %page; /* Internal to submit_request: Performs all necessary processing to submit a single request */ process_single_request: procedure (p_dirname, p_ename); dcl (p_dirname, p_ename) character (*) parameter; dcl (local_dirname, local_pathname, parent_dirname, real_dirname) character (168); dcl (local_ename, parent_ename, real_ename, foreign_ename) character (32); dcl entry_bit_count fixed binary (24); dcl entry_type fixed binary (2); dcl local_error_message character (1024); dcl request_id character (19); dcl the_message_id bit (72) aligned; dcl 1 auto_mseg_message_info aligned like mseg_message_info; local_dirname = p_dirname; local_ename = p_ename; local_pathname = pathname_ (local_dirname, local_ename); /* Determine the type of entry and, if requested and the entry is a link, determine its actual target */ call hcs_$status_minf (local_dirname, local_ename, HCS_DONT_CHASE, entry_type, entry_bit_count, code); if code ^= 0 then COULD_NOT_STATUS_BRANCH: call abort_single_request (code, local_pathname, "Determining type of object."); if (entry_type = star_LINK) then if (^have_starname & (chase_control = DEFAULT_CHASE)) | (chase_control = ALWAYS_CHASE) then do; call hcs_$get_link_target (local_dirname, local_ename, real_dirname, real_ename, code); if code ^= 0 then call abort_single_request (code, local_pathname, "Determining link target of object."); local_dirname = real_dirname; local_ename = real_ename; call hcs_$status_minf (local_dirname, local_ename, HCS_DONT_CHASE, entry_type, entry_bit_count, code); if code ^= 0 then go to COULD_NOT_STATUS_BRANCH; end; else call abort_single_request (error_table_$link, local_pathname, "Object to be transmitted can not be a link."); %page; /**** Check the user's and the daemon's access to object. Both must have explicit non-null access to the branch. */ imft_chk_acl.dirname = local_dirname; imft_chk_acl.ename = local_ename; imft_chk_acl.dir_access = S_ACCESS; imft_chk_acl.seg_access = R_ACCESS; imft_chk_acl.check_aim = "0"b; /* output daemon will check AIM */ imft_chk_acl.effective_ring = user_ring; imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX; /* by default, error is driver's */ general_acl (USER_ACL_IDX).access_name = local_user_id || ".*"; call imft_util_$check_object_acl (addr (imft_chk_acl), code); if code = 0 then code = imft_chk_acl.error_code; if code ^= 0 then if code = error_table_$unimplemented_version then call fatal_ica_error (); else call abort_single_request (NO_ERROR, local_pathname, (imft_chk_acl (imft_chk_acl.bad_acl_idx).error_message)); code = 0; do idx = 1 to hbound (general_acl.entries, 1); if general_acl (idx).status_code ^= 0 then do; code = general_acl (idx).status_code; call notify_user (REQ_TERMED_STR, "0"b, code_message, imft_chk_acl (idx).error_message, local_pathname); /* code_message is already in .error_message */ end; end; if code ^= 0 then call abort_single_request_no_notify (NO_ERROR, local_pathname, "Insufficient driver/user access to object."); /* If -file or -subtree was specified, verify that the branch is of the appropriate type */ if ^(imft_chk_acl.type = ENTRY_TYPE_DIRECTORY) & ^local_rr.include_files then if ^have_starname then call reject_request (NO_ERROR, "Files may not be specified when ""-subtree"" is used."); if (imft_chk_acl.type = ENTRY_TYPE_DIRECTORY) & ^local_rr.include_subtrees then if ^have_starname then do; call ioa_$rsnnl ("Subtrees may not be specified when ""-^[file^]^[extend^]^[update^]"" is used.", local_error_message, ignore_fb21, ^(local_rr.extend | local_rr.update), local_rr.extend, local_rr.update); call reject_request (NO_ERROR, local_error_message); end; if (local_rr.extend | local_rr.update) & ^((imft_chk_acl.type = ENTRY_TYPE_SEGMENT) | (imft_chk_acl.type = ENTRY_TYPE_MSF)) then do; if index (imft_chk_acl.type, "-") = 1 then local_type = substr (imft_chk_acl.type, 2); else local_type = imft_chk_acl.type; call ioa_$rsnnl ("Can only ^[extend^]^[update^] with segments or MSFs, not with ^a type objects.", local_error_message, ignore_fb21, local_rr.extend, local_rr.update, local_type); call abort_single_request (NO_ERROR, local_pathname, local_error_message); end; /* Construct the foreign pathname if -target_pathname was specified */ if local_ft_request.foreign_path_given then do; call get_equal_name_ (local_ename, local_rr.foreign_ename, foreign_ename, code); if code ^= 0 then call abort_single_request (code, local_pathname, "Applying " || rtrim (local_rr.foreign_ename) || " to " || rtrim (local_ename)); end; %page; /**** Must always have S access to containing or parent directory for both driver and user. If the -delete option was used or local object is being extended or updated, both driver and user must have explicit SMA. */ call expand_pathname_ (local_dirname, parent_dirname, parent_ename, ignore_code); imft_chk_acl.dirname = parent_dirname; imft_chk_acl.ename = parent_ename; imft_chk_acl.dir_access = S_ACCESS; imft_chk_acl.seg_access = R_ACCESS; imft_chk_acl.check_aim = "0"b; /* AIM checking done by output daemon */ imft_chk_acl.effective_ring = user_ring; imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX; /* by default, error is driver's */ general_acl (USER_ACL_IDX).access_name = local_user_id || ".*"; call imft_util_$check_object_acl (addr (imft_chk_acl), code); if code = 0 then code = imft_chk_acl.error_code; if code ^= 0 then do; if code = error_table_$unimplemented_version then call fatal_ica_error (); call set_dir_s_error_message (imft_chk_acl.bad_acl_idx); call reject_request (code, local_error_message); end; /* if code ^= 0 */ code = 0; do idx = 1 to hbound (general_acl.entries, 1); if general_acl (idx).status_code ^= 0 then do; code = general_acl (idx).status_code; call set_dir_s_error_message (idx); call convert_status_code_ (code, shortinfo, code_message); call notify_user (REQ_TERMED_STR, code ^= 0, code_message, local_error_message, local_pathname); end; end; if code ^= 0 then call reject_request_no_notify (NO_ERROR, "Insufficient driver/user access to parent directory."); %page; /**** SMA access is not critical here. S access for both driver and user has already been checked above and was all right. The transmitting daemon may be able to do the proper checking. In case it does fail, the transfer will still occur; only the delete operation will not be done. Since this access check is done on the parent directory, there is no need to go through this check for each match on a star name once it has been reported. */ if local_rr.delete & ^reported_dir_sma_warning then do; /* need SMA to parent directory for this case */ imft_chk_acl.dir_access = SMA_ACCESS; imft_chk_acl.seg_access = RW_ACCESS; imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX; /* by default, error is driver's */ general_acl (USER_ACL_IDX).access_name = local_user_id || ".*"; call imft_util_$check_object_acl (addr (imft_chk_acl), code); if code = 0 then code = imft_chk_acl.error_code; if code ^= 0 then do; if code = error_table_$unimplemented_version then call fatal_ica_error (); call set_dir_sma_error_message (imft_chk_acl.bad_acl_idx); call notify_user (local_error_message); end; /* if code ^= 0 */ do idx = 1 to hbound (general_acl.entries, 1); if general_acl (idx).status_code ^= 0 then do; code = general_acl (idx).status_code; call set_dir_sma_error_message (idx); call notify_user (local_error_message); end; end; end; /* if local_rr.delete */ %page; /* Submit the request */ local_ft_request.header.msg_time = clock (); local_ft_request.header.dirname = local_dirname; local_ft_request.header.ename = local_ename; if local_ft_request.foreign_path_given then do; local_ft_request.foreign_dirname = local_rr.foreign_dirname; local_ft_request.foreign_ename = foreign_ename; end; if entry_type = star_DIRECTORY then local_ft_request.directory_creation_mode = local_rr.directory_creation_mode; else local_ft_request.directory_creation_mode = "00"b; mseg_message_info_ptr = addr (auto_mseg_message_info); unspec (mseg_message_info) = ""b; mseg_message_info.version = MSEG_MESSAGE_INFO_V1; mseg_message_info.ms_ptr = addr (local_ft_request); mseg_message_info.ms_len = 36 * currentsize (local_ft_request); mseg_message_info.sender_id = rtrim (mail_destination) || ".*"; mseg_message_info.sender_level = current_ring; mseg_message_info.sender_authorization, mseg_message_info.ms_access_class = mail_access_class; mseg_message_info.sender_max_authorization = mail_access_class; mseg_message_info.sender_process_id = ""b; mseg_message_info.ms_id = ""b; call queue_admin_$add_index (queue_index, mseg_message_info_ptr, the_message_id, code); if code ^= 0 then call abort_single_request (code, local_pathname, "Attempting to add request."); if local_rr.notify then do; /* let the user know it worked */ request_id = request_id_ (local_ft_request.header.msg_time); call notify_user ("Submitted request ^a to transfer ^a to ^a (queue ^d)", (substr (request_id, 7, 8)), local_pathname, foreign_system_name, local_rr.queue); end; n_submitted = n_submitted + 1; /* keep count */ submitted_a_request = "1"b; /* needed by starname processor */ return; %page; /* This particular request cannot be processed, others may be OK. */ abort_single_request: procedure (p_code, p_pathname, p_message); dcl p_code fixed binary (35) parameter; dcl p_pathname character (*) parameter; dcl p_message character (*) parameter; dcl code_message character (100) aligned; dcl notify bit (1); notify = "1"b; go to ABORT_SINGLE_JOIN; abort_single_request_no_notify: entry (p_code, p_pathname, p_message); notify = "0"b; ABORT_SINGLE_JOIN: if have_starname /* there might be others that we can do */ then do; if p_code ^= NO_ERROR then call convert_status_code_ (p_code, shortinfo, code_message); else code_message = ""; if notify then call notify_user ("Request not submitted: ^[^a^/^2x^;^s^]^a^/^2x(^a)", (p_code ^= NO_ERROR), code_message, p_message, p_pathname); n_not_submitted = n_not_submitted + 1; /* count unsuccessful tries */ reported_error = "1"b; /* so we'll know not to do it later */ go to PROCESS_NEXT_STAR_ENTRY; /* non-local goto into submit_request */ end; else if notify then call reject_request (p_code, p_message); else call reject_request_no_notify (p_code, p_message); end abort_single_request; %page; set_dir_s_error_message: proc (p_idx); dcl p_idx fixed binary parameter; if code = error_table_$moderr | code = error_table_$user_not_found then call ioa_$rsnnl ( "^[Driver^;User^] (^a) must have an explicit ACL entry of S to parent directory of object.", local_error_message, ignore_fb21, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name) ; else call ioa_$rsnnl ( "Unable to determine access of ^[driver^;user^] (^a) to the parent directory of object.", local_error_message, ignore_fb21, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name) ; end set_dir_s_error_message; %skip (4); set_dir_sma_error_message: proc (p_idx); dcl p_idx fixed binary parameter; reported_dir_sma_warning = "1"b; /* don't want to come through here again */ /* for current star name */ if code = error_table_$moderr | code = error_table_$user_not_found then call ioa_$rsnnl ( "Warning: ^[Driver^;User^] (^a) must have an explicit ACL entry of SMA to parent directory of object to be deleted.^/^2xRequest will still be submitted.^/^2x(^a)", local_error_message, ignore_fb21, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name, local_pathname); else do; call convert_status_code_ (code, shortinfo, code_message); call ioa_$rsnnl ( "Warning: ^a^/^2xUnable to determine access of ^[driver^;user^] (^a) to the parent directory of object to be deleted.^/^2xRequest will still be submitted.^/^2x(^a)", local_error_message, ignore_fb21, code_message, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name, local_pathname); end; end set_dir_sma_error_message; end process_single_request; end submit_request; %page; /* Reject the transfer request: send a reply to the remote system indicating the reason for the failure */ reject_request: procedure (p_code, p_message); dcl p_code fixed binary (35) parameter; dcl p_message character (*) parameter; dcl code_message character (100) aligned; dcl send_to_user bit (1); send_to_user = "1"b; go to REJECT_JOIN; reject_request_no_notify: entry (p_code, p_message); send_to_user = "0"b; REJECT_JOIN: if p_code ^= NO_ERROR then call convert_status_code_ (p_code, shortinfo, code_message); else code_message = ""; local_bof_reply.abort_request = "1"b; /* tell remote system to not send it */ local_bof_reply.abort_message = rtrim (code_message) || " " || p_message; if send_to_user then call notify_user (REQ_TERMED_STR, p_code ^= 0, code_message, p_message, local_full_pathname); call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "**Request ^d: ^a ^a", local_request_number, code_message, p_message) ; local_icri.version = ICRI_VERSION_1; local_icri.timeout = 5 * ONE_MINUTE; local_icri.record_type = IMFT_BOF; /* this is a reply to their BOF command */ local_icri.record_ptr = addr (local_bof_reply); local_icri.record_lth = 4 * currentsize (local_bof_reply); call iox_$control (data_iocb_ptr, "write_reply_record", addr (local_icri), code); if code ^= 0 then call io_error (code, "Attempting to reply to " || foreign_system_name || "."); call cleanup_handler (); /* cleanup after this one */ go to WAIT_FOR_NEXT_OBJECT; end reject_request; %page; /* Abort receiving an object */ abort_reception: procedure (p_code, p_message); dcl p_code fixed binary (35) parameter; dcl p_message character (*) parameter; dcl code_message character (100) aligned; if p_code ^= 0 then call convert_status_code_ (p_code, shortinfo, code_message); else code_message = ""; call notify_user ("Request for ^a terminated: ^a ^a", local_full_pathname, code_message, p_message); call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "**Request ^d: ^a ^a", local_bof_command.request_number, code_message, p_message); call cleanup_handler (); /* cleanup after it */ go to WAIT_FOR_NEXT_OBJECT; end abort_reception; %skip (4); /**** Unable to communicate with imft_util_$check_object_acl with current version of imft_check_acl structure. */ fatal_ica_error: procedure (); P_code = code; call iodd_msg_ (NORMAL, MASTER, NO_ERROR, IMFT_RECEIVE_OBJECT_, "Invalid imft_check_acl version error from call to imft_util_$check_object_acl."); go to RETURN_FROM_RECEIVE_OBJECT; end fatal_ica_error; %page; /* Respond to an I/O error on the line: return to command level */ io_error: procedure (p_io_code, p_message); dcl p_io_code fixed binary (35) parameter; dcl p_message character (*) parameter; dcl code_message character (100) aligned; if object_in_progress & local_bof_command.notify then do; if p_io_code ^= 0 then /* let the user know */ call convert_status_code_ (p_io_code, shortinfo, code_message); else code_message = ""; call notify_user ("Request for ^a terminated: ^a ^a", local_full_pathname, code_message, p_message); end; call iodd_msg_ (ERROR, MASTER, p_io_code, IMFT_RECEIVE_OBJECT_, "^a", p_message); P_code = p_io_code; /* reflect to the driver which will reinitialize */ if imft_driver_info.debug_mode & (p_io_code ^= imft_et_$timeout) then signal condition (imft_debug_); /* give programmer a look: timeouts are handled by imft_io_ */ go to RETURN_FROM_RECEIVE_OBJECT; end io_error; %skip (4); /* Send a notification to the user */ notify_user: procedure () options (variable); dcl notify_msg character (notify_msg_buffer_used) based (addr (notify_msg_buffer)); dcl notify_msg_buffer_used fixed binary (21); call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, notify_msg_buffer, notify_msg_buffer_used, "0"b, "1"b); call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, INTERACTIVE_DELIVERY, "", notify_msg, mail_access_class, ignore_code); return; end notify_user; %page; /* Analyze results of using backup_load_: assumes any possible errors will be reflected both in the error file and return code from the backup_load_ call */ analyze_backup_results: procedure (P_code); dcl P_code fixed binary (35) parameter; /* return from backup_load_ */ dcl errfile_bc fixed binary (24); dcl backup_code fixed binary (35); dcl backup_message character (20) varying; backup_errors_detected = "0"b; /* until proven otherwise */ if ^imft_driver_info.old_version then foreign_backup_errors = eof_command.backup_errors; else foreign_backup_errors = "0"b; call ios_$detach ("err_file", "", "", ios_status); call hcs_$initiate_count (errfile_dname, errfile_ename, "", errfile_bc, 00b, errfile_ptr, ignore_code); if errfile_ptr ^= null () then /* there is an error file there */ if errfile_bc ^= 0 then /* it's not empty: something went wrong */ call report_backup_errors (); else do; /* no error file, but make sure reload really worked */ if ^static_backup_control.object.found /* didn't find anything with the right name */ then do; backup_code = error_table_$noentry; backup_message = "not received from"; call notify_backup_failure (); end; else if ^static_backup_control.object.loaded /* found it, but couldn't load it */ then do; backup_code = static_backup_control.object.status_code; /* hopefully this will be something informative */ backup_message = "not loaded from"; call notify_backup_failure (); end; else if foreign_backup_errors then call notify_user ("Errors in transmission of ^a; see your mail at ^a.", local_full_pathname, foreign_system_name); end; call hcs_$truncate_file (errfile_dname, errfile_ename, 0, ignore_code); call hcs_$set_bc (errfile_dname, errfile_ename, 0, ignore_code); errfile_attached = "0"b; return; %page; /* Internal to analyze_backup_results: reports errors detected by backup_load_ and recorded in the error file */ report_backup_errors: procedure (); dcl error_file character (errfile_lth) based (errfile_ptr); dcl errfile_lth fixed binary (21); dcl mail_subject character (1024) varying; backup_errors_detected = "1"b; /* let top-level know not to notify */ errfile_lth = divide ((errfile_bc + 8), 9, 21, 0); call ioa_$rsnnl ("Received^[ extension to^]^[ update to^] ^a ^a with errors from ^a (queue ^d)", mail_subject, ignore_fb21, local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name, local_bof_command.queue); call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, ORDINARY_DELIVERY, (mail_subject), error_file, mail_access_class, ignore_code); return; end report_backup_errors; /* Internal to analyze_backup_results: reports failure of backup when no error file present */ notify_backup_failure: procedure (); dcl code_message character (100) aligned; dcl (mail_subject, mail_message) character (1024) varying; call convert_status_code_ (backup_code, shortinfo, code_message); call ioa_$rsnnl ("^a^/^a ^a ^a (queue ^d).^/^a", mail_message, ignore_fb21, code_message, local_full_pathname, backup_message, foreign_system_name, local_bof_command.queue, static_backup_control.object.error_name); call ioa_$rsnnl ("Received^[ extension to^]^[ update to^] ^a ^a with errors from ^a (queue ^d)", mail_subject, ignore_fb21, local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name, local_bof_command.queue); call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, ORDINARY_DELIVERY, (mail_subject), (mail_message), mail_access_class, ignore_code); backup_errors_detected = "1"b; return; end notify_backup_failure; end analyze_backup_results; %page; /* Represents the null entry value: if called, the current object is aborted */ nulle: procedure () options (variable); call abort_reception (NO_ERROR, "Backup system requested tape label."); return; end nulle; %page; /* Parameters */ dcl P_imft_driver_info_ptr pointer parameter; /* -> description of the IMFT driver */ dcl P_fis_info_ptr pointer parameter; /* -> list of I/O switches: 1st is master terminal; 2nd is the connection to the remote system */ dcl P_code fixed binary (35) parameter; /* Remaining declarations */ dcl data_iocb_ptr pointer; /* -> I/O switch for file transmission */ dcl master_iocb_ptr pointer; /* -> I/O switch for master console */ dcl code fixed binary (35); dcl idx fixed binary; dcl ignore_code fixed binary (35); dcl ignore_fb21 fixed binary (21); dcl 1 local_icri aligned like icri automatic; dcl 1 local_bof_command aligned like bof_command; dcl 1 local_bof_reply aligned like bof_reply; dcl 1 local_eof_reply aligned like eof_reply; dcl 1 local_rr aligned like remote_request; dcl 1 imft_chk_acl aligned like imft_check_acl; dcl 1 ios_status aligned, /* for calling ios_$* */ 2 code fixed binary (35), /* actual error code */ 2 io_status bit (36); /* status bits from last I/O operation */ dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl code_message char (100) aligned; dcl input_buffer character (2048); /* for reading commands */ dcl notify_msg_buffer character (2048); /* for construction of user notifications */ dcl source fixed binary; /* which I/O switch has input */ dcl errfile_ptr pointer; /* -> error file generated by backup */ dcl errfile_attached bit (1) aligned; /* ON => error file is setup */ dcl object_in_progress bit (1) aligned; /* ON => something is being received: inform user on abort */ dcl backup_errors_detected bit (1) aligned; /* ON => some errors occured in backup_load_ */ dcl foreign_backup_errors bit (1) aligned; /* ON => error reported in backup_dump_ by foreign system */ dcl (mail_destination, local_personid) character (32); dcl mail_access_class bit (72) aligned; dcl (local_full_pathname, local_dirname, foreign_full_pathname) character (168); dcl foreign_system_name character (32) varying; dcl local_entname character (32); dcl local_request_number fixed binary (35); dcl local_starname character (32); dcl local_type character (32); dcl foreign_equalname character (168); dcl octal_string character (32) aligned; dcl my_group_id character (32); dcl my_user_id character (30); dcl (foreign_user_id, local_user_id) character (32) varying; dcl shortinfo character (8) aligned; dcl user_ring fixed binary (3); dcl local_user_access_id character (32); dcl (acs_write_bracket, current_ring) fixed binary (3); dcl n_submitted fixed binary; dcl n_not_submitted fixed binary; dcl IMFT_RECEIVE_OBJECT_ character (32) static options (constant) initial ("imft_receive_object_"); dcl ONE_MINUTE fixed binary static options (constant) initial (60); dcl NO_ERROR fixed binary (35) initial (0) static options (constant); dcl NO_OBJ_FND_SATISFY_REQ_STR character (42) initial ("No objects were found to satisfy request.") internal static options (constant); dcl REQ_TERMED_STR character (54) initial ("Request terminated: ^[^a^/^2x^;^s^]^a^/^2x(^a)") internal static options (constant); dcl first_call bit (1) aligned static initial ("1"b); dcl 1 static_backup_control aligned static, /* control structure for backup_load_ */ 2 header like backup_control.header, /* ... global data */ 2 object like backup_control.requests; /* ... the actual object to be reloaded */ dcl 1 branch_info aligned int static like create_branch_info; dcl 1 cpo aligned like copy_options; dcl errfile_dname character (168) static; /* name of scratch file used as error file */ dcl errfile_ename character (32) static; dcl errfile_pathname character (168) static; dcl temp_ename character (32) static; dcl temp_dname character (168) static; dcl error_table_$ai_restricted fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$fatal_error fixed bin (35) ext static; dcl error_table_$link fixed bin (35) ext static; dcl error_table_$moderr fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed binary (35) external; dcl error_table_$unsupported_operation fixed bin (35) ext static; dcl error_table_$user_not_found fixed bin (35) ext static; dcl imft_et_$timeout fixed binary (35) external; dcl imft_data_$queue_dirname character (168) external static; dcl HCS_DONT_CHASE fixed binary (1) static options (constant) initial (0); dcl A_EXTENDED_ACCESS bit (36) aligned internal static options (constant) init ("400000000000"b3); dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl backup_load_ entry (pointer, fixed binary (35)); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); dcl convert_aim_attributes_ entry (bit (72) aligned, character (32) aligned); dcl convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned); dcl copy_ entry (ptr); dcl cu_$arg_list_ptr entry () returns (pointer); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl get_authorization_ entry () returns (bit (72) aligned); dcl get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35)); dcl get_group_id_ entry () returns (character (32)); dcl get_pdir_ entry () returns (character (168)); dcl get_ring_ entry () returns (fixed binary (3)); dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35)); dcl hcs_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35)); dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl hcs_$initiate_count entry (character (*), character (*), character (*), fixed binary (24), fixed binary (2), pointer, fixed binary (35)); dcl hcs_$make_seg entry (character (*), character (*), character (*), fixed binary (5), pointer, fixed binary (35)); dcl hcs_$set_bc entry (character (*), character (*), fixed binary (24), fixed binary (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (pointer, fixed binary (35)); dcl hcs_$truncate_file entry (character (*), character (*), fixed binary (19), fixed binary (35)); dcl iod_info_$driver_access_name entry (char (*), char (32), fixed bin (35)); dcl imft_convert_status_code_$decode entry (fixed binary (35)) returns (fixed binary (35)); dcl imft_find_input_switch_ entry (pointer, bit (1) aligned, fixed binary, fixed binary (35)); dcl imft_mail_interface_$deliver_message entry (character (*), character (*), fixed binary, character (*), character (*), bit (72) aligned, fixed binary (35)); dcl imft_pnt_interface_$validate_personid entry (character (*), fixed binary (35)); dcl imft_util_$check_object_acl entry (ptr, fixed bin (35)); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1)); dcl ioa_$rsnnl entry () options (variable); dcl iodd_msg_ entry () options (variable); dcl ios_$attach entry (character (*), character (*), character (*), character (*), 1 aligned like ios_status); dcl ios_$detach entry (character (*), character (*), character (*), 1 aligned like ios_status); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl message_segment_$open entry (char (*), char (*), fixed bin, fixed bin (35)); dcl message_segment_$close entry (fixed bin, fixed bin (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl request_id_ entry (fixed bin (71)) returns (char (19)); dcl queue_admin_$add_index entry (fixed bin, pointer, bit (72) aligned, fixed bin (35)); dcl system_privilege_$ring1_priv_on entry (fixed binary (35)); dcl system_privilege_$ring1_priv_off entry (fixed binary (35)); dcl term_$refname entry (character (*), fixed binary (35)); dcl translate_aim_attributes_ entry (pointer, bit (72) aligned, pointer, bit (72) aligned, fixed binary (35)); dcl unique_chars_ entry (bit (*)) returns (character (15)); dcl (cleanup, imft_debug_, imft_read_abort_, imft_remote_logout_, imft_resynchronize_driver_, linkage_error, sub_error_) condition; dcl (addr, after, before, clock, convert, currentsize, divide, hbound, index, length, max, null, rtrim, string, substr, sum, unspec) builtin; %page; %include access_mode_values; %page; %include acl_structures; %page; %include backup_control; %page; %include condition_info; %page; %include condition_info_header; %page; %include copy_error_info; %page; %include copy_flags; %page; %include copy_options; %page; %include create_branch_info; %page; %include fs_star_; %page; %include "_imft_check_acl"; %page; %include "_imft_cri"; %page; %include "_imft_driver_info"; %page; %include "_imft_fis_info"; %page; %include "_imft_ft_commands"; %page; %include "_imft_ft_request"; %page; %include "_imft_std_commands"; %page; %include iodd_msg_constants; %page; %include mlsys_deliver_info; %page; %include mseg_message_info; %page; %include queue_msg_hdr; %page; %include star_structures; %page; %include sub_error_info; end imft_receive_object_;  imft_transmit_object_.pl1 11/14/88 1517.9rew 11/14/88 1511.2 541818 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* Transmit a storage system object to a remote Multics system */ /* Created: October 1980 by G. Palter */ /* Modified: 27 February 1981 by G. Palter to better report errors from remote system and access validation errors */ /* Modified: 28 February 1981 by G. Palter to add an RQO handler to permit dumping of segments with zero pages */ /* Modified: April 1982 by G. Palter to complete initial implementation */ /* Modified: July 1982 by G. Palter for true AIM support and to properly process I/O error abort control records */ /* Modified: March 1983 by Robert Coren to check for local_io_error */ /* Modified: April 1983 by Robert Coren to implement request for remote transfer ("pull") */ /* Modified: June 1983 by Robert Coren to enforce defer_time */ /* Modified: August 1983 by Robert Coren to enforce minimum_access_class */ /* Modified: November 1983 by Robert Coren to upgrade objects to requestor's authorization */ /* Modified: February 23, 1985 by C. Marker to use version 5 message segments */ /****^ HISTORY COMMENTS: 1) change(87-11-15,Oke), approve(88-08-01,MCR7948), audit(88-10-17,Farley), install(88-10-14,MR12.2-1165): Revise time estimation and calculation to reduce variance. Time estimate is held in static to preserve it across reinits and other restarting occurances. 2) change(88-06-21,Beattie), approve(88-08-01,MCR7948), audit(88-10-17,Farley), install(88-10-14,MR12.2-1165): The following changes were made. a. Change rate averaging to be the same as that used by do_prt_request_. b. Set up imft_driver_info.min_time_to_log to control "Estimated .." display to log. c. Add support for the -delete option. d. Add support to reject requests based on other system's driver software version if -extend or -update options are used. e. Change all access checking to look for explicit ACLs for both user and driver. f. Add access checks on all objects in a subtree if a subtree is to be transfered. 3) change(88-10-21,Beattie), approve(88-08-19,MCR7911), audit(88-10-26,Wallman), install(88-10-28,MR12.2-1199): Add iod_tables_hdr.incl.pl1 to support version 5 iod tables. 4) change(88-11-10,Beattie), approve(88-08-01,PBF7948), audit(88-11-14,Farley), install(88-11-14,MR12.2-1214): Change declaration of local_request_number to match up with what is coming from request_descriptor structure to prevent size condtions. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ imft_transmit_object_: procedure (P_data_iocb_ptr, P_stat_p, P_imft_driver_info_ptr, P_code); system_area_ptr = get_system_free_area_ (); /**** One time initialization */ if first_call then do; process_dname = get_pdir_ (); /* place for access checking errors */ accessfile_ename = "IMFT.access." || unique_chars_ (""b); accessfile_path = pathname_ (process_dname, accessfile_ename); call hcs_$make_seg (process_dname, accessfile_ename, "", RW_ACCESS_BIN, accessfile_ptr, code); if accessfile_ptr = null () then do; /* shouldn't happen, but... */ call iodd_msg_ (code, MASTER, "Creating ^a to hold access check errors.", accessfile_path); return; end; call hcs_$terminate_noname (accessfile_ptr, ignore_code); process_dname = get_pdir_ (); /* create error file for notifications */ errfile_ename = "IMFT." || unique_chars_ (""b); errfile_pathname = pathname_ (process_dname, errfile_ename); call hcs_$make_seg (process_dname, errfile_ename, "", 01010b, errfile_ptr, code); if errfile_ptr = null () then do; /* shouldn't happen, but... */ call iodd_msg_ (ERROR, MASTER, code, IMFT_TRANSMIT_OBJECT_, "Creating ^a as error file for notifications.", errfile_pathname); P_code = code; return; end; call hcs_$terminate_noname (errfile_ptr, ignore_code); first_call = "0"b; /* all set */ end; /* if first_call */ else do; call hcs_$truncate_file (process_dname, accessfile_ename, 0, ignore_code); call hcs_$set_bc (process_dname, accessfile_ename, 0, ignore_code); end; /**** Setup for operation */ data_iocb_ptr = P_data_iocb_ptr; stat_p = P_stat_p; imft_driver_info_ptr = P_imft_driver_info_ptr; P_code = 0; foreign_system_name = rtrim (imft_driver_info.foreign_system.name); foreign_system_version = convert (foreign_system_version, imft_driver_info.foreign_system.imft_version); ds_ptr = iodd_static.driver_ptr; rd_ptr = addr (ds_ptr -> driver_status.descriptor); mseg_message_info_ptr = addr (rd_ptr -> request_descriptor.mseg_message_info_copy); ft_request_ptr = addr (ds_ptr -> driver_status.message); acl_ptr, afs_ptr, errfile_ptr = null (); /* keeps cleanup handler happy */ errfile_attached, send_abort_command = "0"b; my_group_id = get_group_id_ (); /* Person.Project.Tag for access checking */ current_ring = get_ring_ (); on condition (cleanup) call cleanup_handler (); abort_request_label = ABORT_REQUEST; /* for driver's unclaimed signal handler */ /**** Build local description of request */ local_notify = ft_request.notify; local_request_number = rd_ptr -> request_descriptor.seq_id; if ft_request.remote_transfer then do; /**** Set up remote to local transfer request. */ unspec (local_rr) = ""b; local_rr.priority_request = rd_ptr -> request_descriptor.priority_request; local_rr.queue = rd_ptr -> request_descriptor.q; local_rr.request_number = rd_ptr -> request_descriptor.seq_id; local_rr.notify = ft_request.notify; local_rr.local_user = substr (mseg_message_info.sender_id, 1, (length (rtrim (mseg_message_info.sender_id)) - 2)); local_rr.local_user_authorization = mseg_message_info.sender_authorization; local_rr.local_user_ring = mseg_message_info.sender_level; mail_destination = local_rr.local_user; /* user to receive notifications at this end */ mail_access_class = local_rr.local_user_authorization; local_rr.request_info = ft_request; source_full_pathname = pathname_ ((ft_request.dirname), (ft_request.ename)); if ft_request.foreign_path_given then target_full_pathname = pathname_ (ft_request.foreign_dirname, ft_request.foreign_ename); else target_full_pathname = source_full_pathname; if ((ft_request.extend | ft_request.update) & foreign_system_version < 4.0) then do; call ioa_$rsnnl ("Driver on ^a system does not support the ^[-extend^;-update^] option.", abort_message, ignore_fb21, foreign_system_name, ft_request.extend); call abort_request_notify (FLUSH_REQUEST, error_table_$unimplemented_version, abort_message); end; call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "Request ^d ^a output q^d: receive^[ extension to^]^[ update to^] ^a^/^2xfor ^a^[ from ^a^;^s^]^[^/^2xoriginally ^a^]", local_rr.request_number, foreign_system_name, local_rr.queue, local_rr.extend, local_rr.update, target_full_pathname, local_rr.local_user, local_rr.foreign_user_given, local_rr.foreign_user, local_rr.foreign_path_given, source_full_pathname); if (local_rr.notify | ((foreign_system_version < 4.0) & local_rr.delete)) then call notify_user ( "Requesting transfer of ^a from ^a (queue ^d)^[ even though driver on the other system does not support deletion of objects^].", source_full_pathname, foreign_system_name, local_rr.queue, ((foreign_system_version < 4.0) & local_rr.delete)); local_icri.record_type = IMFT_REMOTE_REQUEST; local_icri.record_ptr = addr (local_rr); local_icri.record_lth = 4 * currentsize (local_rr); end; else do; /**** Set up local transfer to remote */ unspec (local_bof_command) = ""b; local_bof_command.continued = rd_ptr -> request_descriptor.continued; local_bof_command.restarted = rd_ptr -> request_descriptor.restarted; local_bof_command.priority_request = rd_ptr -> request_descriptor.priority_request; local_bof_command.queue = rd_ptr -> request_descriptor.q; local_bof_command.request_number = rd_ptr -> request_descriptor.seq_id; local_bof_command.notify = ft_request.notify; local_bof_command.local_dirname = ft_request.dirname; local_bof_command.local_ename = ft_request.ename; /* pathname of object on local system */ local_full_pathname = pathname_ (local_bof_command.local_dirname, local_bof_command.local_ename); local_bof_command.local_user = substr (mseg_message_info.sender_id, 1, (length (rtrim (mseg_message_info.sender_id)) - 2)); local_bof_command.local_user_authorization = mseg_message_info.sender_authorization; local_bof_command.local_user_ring = mseg_message_info.sender_level; mail_destination = local_bof_command.local_user; /* user to receive notifications at this end */ mail_access_class = local_bof_command.local_user_authorization; local_bof_command.foreign_system = ft_request.request; if local_bof_command.foreign_path_given then foreign_full_pathname = pathname_ (local_bof_command.foreign_dirname, local_bof_command.foreign_ename); else foreign_full_pathname = local_full_pathname; /* same pathname wanted on both systems */ if ((ft_request.extend | ft_request.update) & foreign_system_version < 4.0) then do; call ioa_$rsnnl ("Driver on ^a system does not support the ^[-extend^;-update^] option.", abort_message, ignore_fb21, foreign_system_name, ft_request.extend); call abort_request_notify (FLUSH_REQUEST, error_table_$unimplemented_version, abort_message); end; /**** Validate that the object exists */ call hcs_$status_minf (local_bof_command.local_dirname, local_bof_command.local_ename, 0b, local_bof_command.object_type, local_bit_count, code); if code ^= 0 then do; call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "Request ^d ^a output q^d: transmit^[ extension object^]^[ update object^] ^a^/^2xfrom ^a^[ for ^a^;^s^]^[^/^2xas ^a^]", local_bof_command.request_number, foreign_system_name, local_bof_command.queue, local_bof_command.extend, local_bof_command.update, local_full_pathname, local_bof_command.local_user, local_bof_command.foreign_user_given, local_bof_command.foreign_user, local_bof_command.foreign_path_given, foreign_full_pathname); call abort_request_notify (FLUSH_REQUEST, code, "Determining type of object."); end; if local_bof_command.object_type = DIRECTORY then /* be sure to notice MSFs */ if local_bit_count ^= 0 then local_bof_command.object_type = MSF; /**** Log beginning of transmission, inform user if requested, and validate access */ call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "Request ^d ^a output q^d: transmit^[ extension^]^[ update^] ^a ^a^/^2xfrom ^a^[ for ^a^;^s^]^[^/^2xas ^a^]", local_bof_command.request_number, foreign_system_name, local_bof_command.queue, local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, local_bof_command.local_user, local_bof_command.foreign_user_given, local_bof_command.foreign_user, local_bof_command.foreign_path_given, foreign_full_pathname); if local_bof_command.object_type = LINK then call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "Object to be transmitted can not be a link."); allow_delete = "1"b; /* until proven otherwise */ call validate_access (); /* doesn't return if access isn't OK */ call estimate_time (object_length, time_needed_to_transmit); time_pict = float (time_needed_to_transmit) / float (ONE_MINUTE); if ds_ptr -> driver_status.defer_time_limit > 0 /* should we be checking against time limit? */ then if time_needed_to_transmit > ds_ptr -> driver_status.defer_time_limit then call abort_request_notify (KEEP_REQUEST, NO_ERROR, "Request deferred automatically because it would exceed time limit. (estimated time " || time_pict || " minutes.)"); if local_bof_command.notify then call notify_user ( "Beginning transmission of^[ extension^]^[ update^] ^a ^a to ^a (queue ^d). Estimated time: ^.1f minutes.", local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name, local_bof_command.queue, float (time_needed_to_transmit) / float (ONE_MINUTE)); /**** Establish handlers for various error conditions which might arise */ on condition (daemon_again), condition (daemon_again_slave) begin; /* restart current request */ if send_abort_command then /* need to cleanup after ourselves */ call write_abort_command (IMFT_ABORT_RESTARTED, 0); call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "Restarting request."); go to RESTART_THIS_REQUEST; end; on condition (daemon_save) begin; /* save this request */ if send_abort_command then /* started doing something */ call write_abort_command (IMFT_ABORT_SAVED, 0); call cleanup_handler (); /* cleanup the mess */ end; on condition (daemon_defer) begin; /* operator request deferral */ if send_abort_command then /* indicate what happened */ call write_abort_command (IMFT_ABORT_DEFERRED, 0); call abort_request (KEEP_REQUEST, NO_ERROR, "Operator deferred request until a later time."); end; on condition (daemon_cancel), condition (daemon_kill) begin; /* operator has cancelled request */ if send_abort_command then /* explain to foreign system */ call write_abort_command (IMFT_ABORT_CANCELLED, 0); call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "Operator cancelled the request."); end; on condition (imft_write_abort_) call analyze_write_abort; iodd_static.request_in_progress = "1"b; /* as of now, it's running */ go to START_REQUEST; /* get the ball started */ /**** Control arrives here to RESTART the current request */ RESTART_THIS_REQUEST: local_bof_command.continued = "1"b; /* looks like it's being continued */ /**** Control arrives here to START the current request */ /**** Prepare to invoke backup_dump_: construct description of the dump and terminate the backup system to cleanup from last use in this process (if any) */ START_REQUEST: call estimate_time (object_length, time_needed_to_transmit); time_pict = float (time_needed_to_transmit) / float (ONE_MINUTE); if ds_ptr -> driver_status.defer_time_limit > 0 /* should we be checking against time limit? */ then if time_needed_to_transmit > ds_ptr -> driver_status.defer_time_limit then call abort_request_notify (KEEP_REQUEST, NO_ERROR, "Request deferred automatically after restart because it would exceed time limit. (estimated time " || time_pict || " minutes.)"); /**** All set to transmit. */ if time_needed_to_transmit > imft_driver_info.min_time_to_log then call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2xEstimated time: ^.1f minutes.", float (time_needed_to_transmit) / float (ONE_MINUTE)); static_backup_control.version = BACKUP_CONTROL_VERSION_5; static_backup_control.tape_entry = nulle; string (static_backup_control.options) = ""b; static_backup_control.debug_sw = "1"b; static_backup_control.error_file = "1"b; static_backup_control.caller_handles_conditions = "1"b; static_backup_control.preattached = "1"b; /* we supply the I/O switch */ static_backup_control.data_iocb = data_iocb_ptr; static_backup_control.enforce_max_access_class = "1"b; static_backup_control.maximum_access_class = imft_driver_info.local_system.access_ceiling; /* nothing higher than this class is dumped */ static_backup_control.enforce_min_access_class = "1"b; static_backup_control.minimum_access_class = imft_driver_info.local_system.access_floor; /* nothing lower than this class is dumped */ static_backup_control.dont_dump_upgraded_dirs = "1"b; static_backup_control.maximum_dir_access_class = local_bof_command.object_access_class; /* don't dump any upgraded directories */ static_backup_control.check_effective_access = "1"b; static_backup_control.user_for_access_check.id = rtrim (local_bof_command.local_user) || ".*"; static_backup_control.user_for_access_check.authorization = local_bof_command.local_user_authorization; static_backup_control.user_for_access_check.ring = local_bof_command.local_user_ring; /* don't dump it if the user can't access it either */ static_backup_control.upgrade_to_user_auth = "1"b; /* don't allow creation of objects at lower level than user's */ /* authorization */ static_backup_control.request_count = 1; /* one and only one object to dump */ static_backup_control.object.path = local_full_pathname; static_backup_control.object.new_path = ""; string (static_backup_control.object.switches) = ""b; static_backup_control.object.no_primary_sw = "1"b; call term_$refname ("backup_dump_", ignore_code); call term_$refname ("backup_map_", ignore_code); call term_$refname ("bk_ss_", ignore_code); call ios_$attach ("err_file", "file", errfile_pathname, "w", ios_status); if ios_status.code ^= 0 then /* not the user's fault */ call abort_request (KEEP_REQUEST, ios_status.code, "Setting up backup error file."); errfile_attached = "1"b; /* got one */ /**** Send a BOF command to inform the remote system that we have a file/subtree ready for transmission */ local_icri.record_type = IMFT_BOF; local_icri.record_ptr = addr (local_bof_command); local_icri.record_lth = 4 * currentsize (local_bof_command); end; /* if ^ft_request.remote_transfer */ local_icri.version = ICRI_VERSION_1; local_icri.timeout = 5 * ONE_MINUTE; call iox_$control (data_iocb_ptr, "write_command_record", addr (local_icri), code); if code ^= 0 then /* something's wrong */ if code = imft_et_$reply_pending then do; /* ... an unsolicited reply: analyze it */ local_icri.record_ptr = addr (input_buffer); local_icri.record_max_lth = length (input_buffer); call iox_$control (data_iocb_ptr, "read_reply_record", addr (local_icri), code); if code = 0 then call analyze_unsolicited_reply (); else call io_error (code, "Attempting to read from " || foreign_system_name || "."); end; else call io_error (code, "Attempting to write to " || foreign_system_name || "."); send_abort_command = "1"b; /* any errors now must be reflected to the remote system */ /* Wait for a reply from the remote system: if the remote system rejected our BOF command, the reply will contain the reason in a format suitable for notifying the user */ local_icri.record_ptr = addr (input_buffer); /* a place for the reply */ local_icri.record_max_lth = length (input_buffer); call iox_$control (data_iocb_ptr, "read_reply_record", addr (local_icri), code); if code ^= 0 then call io_error (code, "Attempting to read from " || foreign_system_name || "."); if local_icri.record_type = IMFT_BOF then do; /* it's a reply to the BOF command all right ... */ bof_reply_ptr = addr (input_buffer); /* ... need to know where it is */ if bof_reply.request_number ^= local_request_number then call abort_request_fatal (KEEP_REQUEST, NO_ERROR, "Reply received from " || foreign_system_name || " for wrong request."); else if bof_reply.abort_request then do; /* ... didn't like our request */ send_abort_command = "0"b; /* ... ... no need to confuse the remote system */ call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "Message from " || foreign_system_name || ": " || bof_reply.abort_message); end; end; else call analyze_unsolicited_reply (); /* weren't expecting this reply */ if ft_request.remote_transfer /* all we have to send is the control record */ then do; if local_rr.notify then call notify_user ("Transfer of ^a queued at ^a", source_full_pathname, foreign_system_name); call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2x^a", bof_reply.abort_message); end; else do; /* Transmit the file/subtree using the hierarchy dumper */ on condition (record_quota_overflow) ; /* can happen on zero pages in segments being transferred */ time_started = clock (); call backup_dump_ (addr (static_backup_control), code); call iox_$control (data_iocb_ptr, "runout", null (), ignore_code); /* force all data out */ time_taken = divide (clock () - time_started, ONE_MILLION, 35, 0); /* get elapsed time in seconds */ call analyze_backup_results (code); /**** Send an EOF command to indicate completion of the file/subtree and notify the user if requested. */ local_icri.version = ICRI_VERSION_1; local_icri.timeout = 5 * ONE_MINUTE; /* give the other side a chance */ local_icri.record_type = IMFT_EOF; local_icri.record_ptr = addr (local_eof_command); local_icri.record_lth = 4 * currentsize (local_eof_command); local_eof_command.request_number = local_request_number; local_eof_command.backup_errors = backup_errors_detected | local_bof_command.delete & ^allow_delete; /* this will flag user at other end to */ /* check his messages here */ call iox_$control (data_iocb_ptr, "write_command_record", addr (local_icri), code); if code ^= 0 then /* something's wrong */ if code = imft_et_$reply_pending then do; /* ... an unsolicited reply: analyze it */ local_icri.record_ptr = addr (input_buffer); local_icri.record_max_lth = length (input_buffer); call iox_$control (data_iocb_ptr, "read_reply_record", addr (local_icri), code); if code = 0 then call analyze_unsolicited_reply (); else call io_error (code, "Attempting to read from " || foreign_system_name || "."); end; else call io_error (code, "Attempting to write to " || foreign_system_name || "."); foreign_backup_errors = "0"b; if ^imft_driver_info.old_version then do; /* EOF reply will tell us whether object arrived successfully */ local_icri.record_ptr = addr (input_buffer); /* a place for the reply */ local_icri.record_max_lth = length (input_buffer); call iox_$control (data_iocb_ptr, "read_reply_record", addr (local_icri), code); if code ^= 0 then call io_error (code, "Attempting to read from " || foreign_system_name || "."); if local_icri.record_type = IMFT_EOF then do; /* it's a reply to the EOF command all right ... */ eof_reply_ptr = addr (input_buffer); /* ... need to know where it is */ if eof_reply.request_number ^= local_request_number then call abort_request_fatal (KEEP_REQUEST, NO_ERROR, "Reply received from " || foreign_system_name || " for wrong request."); if eof_reply.error /* foreign system wasn't happy */ then do; call notify_user ("Errors in reception of ^a; See your messages at ^a.", local_full_pathname, foreign_system_name); foreign_backup_errors = "1"b; end; end; else call analyze_unsolicited_reply (); /**** Update time estimate after transmission has been validated. */ if time_taken > MINIMUM_TIME_TO_AVERAGE /* did it take long enough not to be lost in noise? */ then call revise_time_estimate (object_length); end; if local_bof_command.delete & allow_delete & ^backup_errors_detected & ^foreign_backup_errors then do; unspec (delete_options) = ""b; delete_options.force = "1"b; delete_options.directory = "1"b; delete_options.segment = "1"b; delete_options.link = "1"b; deleting_object = "1"b; call delete_$path (local_bof_command.local_dirname, local_bof_command.local_ename, string (delete_options), "", code); deleting_object = "0"b; if code ^= 0 then do; call convert_status_code_ (code, shortinfo, code_message); call notify_user ("Error occured while attempting to delete ^a^/(^a)", local_full_pathname, code_message); end; end; RESUME_AFTER_DELETE: if local_bof_command.notify then /* made it ... */ if ^backup_errors_detected & ^foreign_backup_errors then /* ... and user not informed because of backup errors */ call notify_user ("Transmitted^[ extension^]^[ update^] ^a ^a without errors to ^a (queue ^d).", local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name, local_bof_command.queue); if backup_errors_detected | foreign_backup_errors | local_bof_command.delete & ^allow_delete then do; call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2xNonfatal errors in transfer detected at ^[^a^;^s^]^[ and ^]^[^a^].", backup_errors_detected | local_bof_command.delete & ^allow_delete, imft_driver_info.local_system.name, backup_errors_detected & foreign_backup_errors, foreign_backup_errors, foreign_system_name); if local_bof_command.delete then call notify_user ("Unable to delete ^a ^a due to access errors at ^a.", OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, imft_driver_info.local_system.name); end; call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "^2xTransmitted request ^d.", local_request_number); end; /* if ^ft_request.remote_transfer */ send_abort_command = "0"b; /* all done with this request */ rd_ptr -> request_descriptor.keep_in_queue = "0"b;/* done with it */ /**** Cleanup and return to caller */ RETURN_FROM_TRANSMIT_OBJECT: call cleanup_handler (); /* clean things up */ rd_ptr -> request_descriptor.dont_delete = "1"b; /* delete done in driver */ rd_ptr -> request_descriptor.finished = "1"b; /* all done */ iodd_static.request_in_progress = "0"b; return; /* Abort the request: The entry is called from the driver's any_other handler if an unexpected condition is detected during processing of a request */ abort_running_request: entry (P_condition_name); condition_name = P_condition_name; go to abort_request_label; /* unwind the stack */ ABORT_REQUEST: if deleting_object then do; deleting_object = "0"b; call notify_user ("The ""^a"" condition was signalled during the deletion of object,^/^a.", condition_name, local_full_pathname); go to RESUME_AFTER_DELETE; end; else call abort_request_notify (FLUSH_REQUEST, NO_ERROR, """" || rtrim (condition_name) || """ condition occurred during processing of request."); %page; /* Handler for imft_write_abort_: This condition is raised during writing of backup records because of an I/O error or an unsolicited reply from the remote system */ analyze_write_abort: procedure (); local_icri.version = ICRI_VERSION_1; local_icri.timeout = 5 * ONE_MINUTE; /* give the remote system a chance */ local_icri.record_ptr = addr (input_buffer); local_icri.record_max_lth = length (input_buffer); call iox_$control (data_iocb_ptr, "get_abort_info", addr (local_icri), code); if code ^= 0 then call io_error (code, "Attempting to read from " || foreign_system_name || "."); call analyze_unsolicited_reply (); go to RETURN_FROM_TRANSMIT_OBJECT; /* shouldn't get here */ end analyze_write_abort; %page; /**** Analyze an unexpected reply from the remote system */ analyze_unsolicited_reply: procedure (); dcl abort_code_picture picture "(9)9"; rd_ptr -> request_descriptor.keep_in_queue = "1"b;/* not the user's fault: try this one again later */ send_abort_command = "0"b; /* other side caused termination: no need to acknowledge */ if local_icri.record_type = IMFT_LOGOUT then do; if local_notify then call notify_user ("Request for ^[^a^s^;^s^a^] deferred: ^a's input driver disconnected.", ft_request.remote_transfer, source_full_pathname, local_full_pathname, foreign_system_name); signal condition (imft_remote_logout_); end; else if local_icri.record_type = IMFT_RESYNCHRONIZE then do; if local_notify then call notify_user ("Request for ^[^a^s^;^s^a^] deferred: ^a requested driver to reinitialize.", ft_request.remote_transfer, source_full_pathname, local_full_pathname, foreign_system_name); signal condition (imft_resynchronize_driver_); end; else if local_icri.record_type = IMFT_ABORT then do; abort_command_ptr = local_icri.record_ptr; /* an I/O error most likely */ if abort_command.reason = IMFT_ABORT_IO_ERROR | abort_command.reason = IMFT_ABORT_LOCAL_IO_ERROR then do; if abort_command.reason = IMFT_ABORT_IO_ERROR /* came from foreign system */ then abort_command.code = imft_convert_status_code_$decode (abort_command.code); call io_error (abort_command.code, "Attempting to write to " || foreign_system_name || "."); end; else call abort_request_fatal (KEEP_REQUEST, NO_ERROR, "Unexpected abort code " || ltrim (convert (abort_code_picture, abort_command.reason)) || " from " || foreign_system_name || "."); end; else call abort_request_fatal (KEEP_REQUEST, NO_ERROR, "Unexpected reply code ^d from ^a."); end analyze_unsolicited_reply; %page; /**** Cleanup after a request */ cleanup_handler: procedure (); if acl_ptr ^= null () then do; free general_acl in (system_area); acl_ptr = null (); end; if afs_ptr ^= null () then do; call hcs_$truncate_file (process_dname, accessfile_ename, 0, ignore_code); call hcs_$set_bc (process_dname, accessfile_ename, 0, ignore_code); afs_ptr = null (); end; iodd_static.segptr = null (); /* have finished with it */ if errfile_ptr ^= null () then do; call hcs_$terminate_noname (errfile_ptr, ignore_code); errfile_ptr = null (); end; if errfile_attached then do; call ios_$detach ("err_file", "", "", ios_status); call hcs_$truncate_file (process_dname, errfile_ename, 0, ignore_code); call hcs_$set_bc (process_dname, errfile_ename, 0, ignore_code); errfile_attached = "0"b; end; if send_abort_command then /* indicate the request wasn't finished */ call write_abort_command (IMFT_ABORT_ABORTED, 0); return; end cleanup_handler; %page; /**** Abort the current request */ abort_request: procedure (p_keep_request, p_code, p_message); dcl p_keep_request bit (1) aligned parameter; dcl p_code fixed binary (35) parameter; dcl p_message character (*) parameter; dcl (notify, fatal) bit (1) aligned; notify, fatal = "0"b; /* tell user only if start of transmission message was sent */ go to ABORT_REQUEST_COMMON; /**** Abort the current request and reinitialize the driver */ abort_request_fatal: entry (p_keep_request, p_code, p_message); notify = "0"b; /* tell user only if start of transmission message was sent */ fatal = "1"b; go to ABORT_REQUEST_COMMON; /**** Abort the current request and inform the user */ abort_request_notify: entry (p_keep_request, p_code, p_message); notify = "1"b; /* tell the user no matter what */ fatal = "0"b; ABORT_REQUEST_COMMON: if send_abort_command then /* need to report that an abort happened */ call write_abort_command (IMFT_ABORT_ABORTED, 0); if p_code ^= 0 then call convert_status_code_ (p_code, shortinfo, code_message); else code_message = ""; if (notify | local_notify) then /* let them know what happened */ call notify_user (USER_REQ_DEF_OR_TERM, p_keep_request, p_code ^= 0, code_message, p_message, ft_request.remote_transfer, source_full_pathname, local_full_pathname); call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "**Request ^d: ^a ^a", local_request_number, code_message, p_message) ; call iodd_msg_ (LOG, MASTER, NO_ERROR, "", "Processing of request ^d ^[deferred^;terminated^].", local_request_number, p_keep_request); rd_ptr -> request_descriptor.keep_in_queue = p_keep_request; if fatal then do; P_code = error_table_$fatal_error; /* forces the driver to reinitialize */ if imft_driver_info.debug_mode then /* ... but give the programmer a look first */ signal condition (imft_debug_); end; go to RETURN_FROM_TRANSMIT_OBJECT; end abort_request; %page; /**** Report an I/O error during the processing of a request */ io_error: procedure (p_io_code, p_message); dcl p_io_code fixed binary (35) parameter; dcl p_message character (*); if send_abort_command then /* try to cleanup the transmission */ call write_abort_command (IMFT_ABORT_IO_ERROR, imft_convert_status_code_$encode (p_io_code)); if local_notify then do; /* they were told it started: tell them it was stopped */ if p_io_code ^= 0 then call convert_status_code_ (p_io_code, shortinfo, code_message); else code_message = ""; call notify_user ("Processing of request ^[^a^s^;^s^a^] deferred: ^a ^a", ft_request.remote_transfer, source_full_pathname, local_full_pathname, code_message, p_message); end; call iodd_msg_ (ERROR, MASTER, p_io_code, IMFT_TRANSMIT_OBJECT_, "^a", p_message); rd_ptr -> request_descriptor.keep_in_queue = "1"b; P_code = p_io_code; /* let our caller reinitiatilze the driver */ if imft_driver_info.debug_mode & (p_io_code ^= imft_et_$timeout) then signal condition (imft_debug_); /* give programmer a look: timeouts are handled by imft_io_ */ go to RETURN_FROM_TRANSMIT_OBJECT; end io_error; %skip (4); /**** Send a notification to the user */ notify_user: procedure () options (variable); dcl notify_msg character (notify_msg_buffer_used) based (addr (notify_msg_buffer)); dcl notify_msg_buffer_used fixed binary (21); call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, notify_msg_buffer, notify_msg_buffer_used, "0"b, "1"b); call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, INTERACTIVE_DELIVERY, "", notify_msg, mail_access_class, ignore_code); return; end notify_user; %page; /**** Write an abort command to the remote system */ write_abort_command: procedure (p_abort_type, p_code); dcl p_abort_type fixed binary parameter; dcl p_code fixed binary (35) parameter; local_abort_command.reason = p_abort_type; local_abort_command.code = p_code; local_icri.version = ICRI_VERSION_1; local_icri.timeout = 5 * ONE_MINUTE; /* give it a chance to get there */ local_icri.record_type = IMFT_ABORT; local_icri.record_ptr = addr (local_abort_command); local_icri.record_lth = 4 * currentsize (local_abort_command); call iox_$control (data_iocb_ptr, "write_command_record", addr (local_icri), ignore_code); send_abort_command = "0"b; /* we sent it */ return; end write_abort_command; %page; /****^ Validates access to transfer a file/subtree: Let SPerson.SProj be the user who is sending the file/subtree, let MPerson.MProj be the user who is running the daemon, and let SPath be the pathname of the file/subtree to be transmitted. Then: (1) SPerson.SProj and MPerson.MProj must have explicit "r" access to SPath if it is a file or explicit "s" access if it is a subtree, (2) the access class of SPath must be less than or equal to the access ceiling computed by the driver, and (3) the access class of SPath must be less than or equal to the process authorization of SPerson.SProj. To perform these checks, MPerson.MProj requires explicit "s" access to the parent of SPath. Access to each of the individual branches within a subtree is validated here. */ validate_access: procedure () options (non_quick); /* it has a rather large amount of automatic storage */ dcl access_file character (accessfile_lth) based (accessfile_ptr); dcl local_error_message character (1024); dcl local_pathname character (168); dcl local_user_id character (32) varying; dcl message_len fixed bin (21); dcl my_user_id character (32) varying; dcl parent_dirname character (168); dcl parent_ename character (32); dcl transfer_ring fixed binary (3); dcl idx fixed binary; local_user_id = rtrim (local_bof_command.local_user); my_user_id = substr (my_group_id, 1, (length (rtrim (my_group_id)) - 2)); acl_count = 2; allocate general_acl in (system_area) set (acl_ptr); general_acl.version = GENERAL_ACL_VERSION_1; general_acl.count = acl_count; general_acl (DRIVER_ACL_IDX).access_name = my_user_id || ".*"; general_acl (USER_ACL_IDX).access_name = local_user_id || ".*"; local_pathname = pathname_ (local_bof_command.local_dirname, local_bof_command.local_ename); transfer_ring = max (current_ring, local_bof_command.local_user_ring); if local_bof_command.local_dirname = ">" then call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "IMFT can not transfer branches under the root."); %page; /**** User and driver must have explicit S access to parent directory. */ call expand_pathname_ (local_bof_command.local_dirname, parent_dirname, parent_ename, ignore_code); imft_chk_acl.version = IMFT_CHECK_ACL_VERSION_1; imft_chk_acl.foreign_sys_name = foreign_system_name; imft_chk_acl.dirname = parent_dirname; imft_chk_acl.ename = parent_ename; imft_chk_acl.gen_acl_ptr = acl_ptr; imft_chk_acl.effective_ring = transfer_ring; imft_chk_acl.sys_auth_ceiling = imft_driver_info.local_system.access_ceiling; imft_chk_acl.sys_auth_floor = imft_driver_info.local_system.access_floor; imft_chk_acl.user_auth = local_bof_command.local_user_authorization; imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX; /* errors are initially driver's */ imft_chk_acl.dir_access = S_ACCESS; imft_chk_acl.seg_access = R_ACCESS; imft_chk_acl.accessfile_pathname = accessfile_path; imft_chk_acl.check_aim = "0"b; call imft_util_$check_object_acl (addr (imft_chk_acl), code); if code = 0 then code = imft_chk_acl.error_code; if code ^= 0 then do; /* unable to fully check access if code ^= 0 */ if code = error_table_$unimplemented_version then call abort_request_fatal (KEEP_REQUEST, code, BAD_CHK_OBJ_ACL_STR); call set_dir_s_error_message (imft_chk_acl.bad_acl_idx); call abort_request_notify (FLUSH_REQUEST, code, substr (local_error_message, 1, message_len)); end; /* if code ^= 0 */ code = 0; do idx = 1 to hbound (general_acl.entries, 1); if general_acl (idx).status_code ^= 0 then do; code = general_acl (idx).status_code; call convert_status_code_ (code, shortinfo, code_message); call set_dir_s_error_message (idx); call notify_user (USER_REQ_DEF_OR_TERM, FLUSH_REQUEST, code ^= 0, code_message, local_error_message, ft_request.remote_transfer, source_full_pathname, local_full_pathname); end; end; if code ^= 0 then call abort_request (FLUSH_REQUEST, NO_ERROR, "Insufficient access to parent directory of object."); %page; /**** User and driver must need explicit SMA on parent directory if deletion is selected. */ if local_bof_command.delete then do; imft_chk_acl.dir_access = SMA_ACCESS; imft_chk_acl.seg_access = RW_ACCESS; imft_chk_acl.check_aim = "0"b; imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX; /* errors are initially driver's */ call imft_util_$check_object_acl (addr (imft_chk_acl), code); if code = 0 then code = imft_chk_acl.error_code; if code ^= 0 then do; /* unable to fully check access if code ^= 0 */ if code = error_table_$unimplemented_version then call abort_request_fatal (KEEP_REQUEST, code, BAD_CHK_OBJ_ACL_STR); call notify_dir_sma_error (imft_chk_acl.bad_acl_idx); end; /* if code ^= 0 */ do idx = 1 to hbound (general_acl.entries, 1); if general_acl (idx).status_code ^= 0 then do; code = general_acl (idx).status_code; call notify_dir_sma_error (idx); end; end; end; /* if local_bof_command.delete */ %page; /**** Check access to object. */ imft_chk_acl.dirname = local_bof_command.local_dirname; imft_chk_acl.ename = local_bof_command.local_ename; imft_chk_acl.dir_access = S_ACCESS; imft_chk_acl.seg_access = R_ACCESS; imft_chk_acl.check_aim = "1"b; imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX; /* errors are initially driver's */ call imft_util_$check_object_acl (addr (imft_chk_acl), code); if code = 0 then code = imft_chk_acl.error_code; if code ^= 0 /* error_message already contains expansion of "code" */ then do; /* unable to fully check access if code ^= 0 */ if code = error_table_$unimplemented_version then call abort_request_fatal (KEEP_REQUEST, code, BAD_CHK_OBJ_ACL_STR); call abort_request_notify (FLUSH_REQUEST, NO_ERROR, (imft_chk_acl (imft_chk_acl.bad_acl_idx).error_message)); end; if imft_chk_acl.type = ENTRY_TYPE_LINK then call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "Object to be transmitted can not be a link."); code = 0; do idx = 1 to hbound (general_acl.entries, 1); if general_acl (idx).status_code ^= 0 then do; code = general_acl (idx).status_code; call notify_user (USER_REQ_DEF_OR_TERM, FLUSH_REQUEST, "0"b, "", imft_chk_acl (idx).error_message, ft_request.remote_transfer, source_full_pathname, local_full_pathname); end; end; if code ^= 0 then call abort_request (FLUSH_REQUEST, NO_ERROR, "Insufficient driver or user access to object."); %page; if imft_chk_acl.type = ENTRY_TYPE_DIRECTORY then do; /* now to check the subtree */ imft_chk_acl.dir_access = S_ACCESS; imft_chk_acl.seg_access = R_ACCESS; imft_chk_acl.check_aim = "1"b; imft_chk_acl.bad_acl_idx = DRIVER_ACL_IDX; /* errors are initially driver's */ call imft_util_$check_subtree_acl (addr (imft_chk_acl), code); if code = 0 then code = imft_chk_acl.error_code; if code ^= 0 then do; /* unable to fully check access if code ^= 0 */ if code = error_table_$unimplemented_version then call abort_request_fatal (KEEP_REQUEST, code, "Attempted to call imft_util_$check_subtree_acl"); call abort_request_notify (FLUSH_REQUEST, code, "Error while checking access to objects in subtree."); end; /**** All access errors are in file. */ call hcs_$initiate_count (process_dname, accessfile_ename, "", accessfile_bc, ignore_fb2, accessfile_ptr, ignore_code); if accessfile_ptr ^= null then if accessfile_bc ^= 0 then do; accessfile_lth = divide ((accessfile_bc + 8), 9, 21, 0); call ioa_$rsnnl ("Access errors detected for request to ^a (queue ^d)", mail_subject, ignore_fb21, foreign_system_name, local_bof_command.queue); call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, ORDINARY_DELIVERY, (mail_subject), access_file, mail_access_class, ignore_code); call hcs_$truncate_file (process_dname, accessfile_ename, 0, ignore_code); call hcs_$set_bc (process_dname, accessfile_ename, 0, ignore_code); end; /* if accessfile_ptr ^null and accessfile_bc ^=0 */ if imft_chk_acl.allow_transfer then do; if ^imft_chk_acl.objects_to_transfer then call abort_request (FLUSH_REQUEST, NO_ERROR, "There is nothing to transfer due to errors detected while checking access of objects in subtree." ); if imft_chk_acl.found_inner_ring_object & local_bof_command.delete then do; allow_delete = "0"b; call notify_user ( "Unable to delete subtree due to presense of inner-ring objects found in subtree.^/^2x(^a)", local_pathname); end; end; else call abort_request (FLUSH_REQUEST, NO_ERROR, "Unable to allow transfer of object due to access errors."); end; /* if type = direcotry */ local_bof_command.object_access_class = local_bof_command.local_user_authorization; /* this is access class it will really be sent at */ return; %page; set_dir_s_error_message: proc (p_idx); dcl p_idx fixed binary parameter; if code = error_table_$moderr | code = error_table_$user_not_found then call ioa_$rsnnl ( "^[Driver^;User^] (^a) must have an explicit ACL entry of S to parent directory of object.", local_error_message, message_len, (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name); else call ioa_$rsnnl ( "Could not determine driver's (^a) and user's (^a) access to parent directory of object.", local_error_message, message_len, my_user_id, local_user_id); end set_dir_s_error_message; %skip (4); notify_dir_sma_error: proc (p_idx); dcl p_idx fixed binary parameter; call convert_status_code_ (code, shortinfo, code_message); if code = error_table_$moderr | code = error_table_$user_not_found then call notify_user ( "Warning: ^[Driver^;User^] (^a) must have an explicit ACL entry of SMA to parent directory of object to be deleted.^/^2xDeletion will not be performed.^/^2x(^a)", (p_idx = DRIVER_ACL_IDX), general_acl (p_idx).access_name, local_pathname); else call notify_user ( "Warning: ^a^/^2xCould not determine driver's (^a) and user's (^a) access to delete object.^/^2x(^a)^/Object will not be deleted.", code_message, my_user_id, local_user_id, local_pathname); allow_delete = "0"b; /* this will flag user at other end to check message here */ /* about lack of deletion access */ end notify_dir_sma_error; end validate_access; %page; /* Analyze results of using backup_dump_: assumes any possible errors will be reflected both in the error file and return code from the backup_dump_ call */ analyze_backup_results: procedure (p_code); dcl p_code fixed binary (35) parameter; /* return from backup_dump_ */ dcl errfile_bc fixed binary (24); backup_errors_detected = "0"b; /* until proven otherwise */ call ios_$detach ("err_file", "", "", ios_status); call hcs_$initiate_count (process_dname, errfile_ename, "", errfile_bc, 00b, errfile_ptr, ignore_code); if errfile_ptr ^= null () then /* there is an error file there */ if errfile_bc ^= 0 then /* it's not empty: something went wrong */ call report_backup_errors (); call hcs_$truncate_file (process_dname, errfile_ename, 0, ignore_code); call hcs_$set_bc (process_dname, errfile_ename, 0, ignore_code); errfile_attached = "0"b; return; /**** Internal to analyze_backup_results: reports errors detected by backup_dump_ and recorded in the error file. */ report_backup_errors: procedure (); dcl error_file character (errfile_lth) based (errfile_ptr); dcl errfile_lth fixed binary (21); backup_errors_detected = "1"b; /* let top-level know not to notify */ errfile_lth = divide ((errfile_bc + 8), 9, 21, 0); call ioa_$rsnnl ("Transmitted^[ extension^]^[ update^] ^a ^a with errors to ^a (queue ^d)", mail_subject, ignore_fb21, local_bof_command.extend, local_bof_command.update, OBJECT_TYPES (local_bof_command.object_type), local_full_pathname, foreign_system_name, local_bof_command.queue); call imft_mail_interface_$deliver_message ((foreign_system_name), mail_destination, ORDINARY_DELIVERY, (mail_subject), error_file, mail_access_class, ignore_code); return; end report_backup_errors; end analyze_backup_results; %page; /**** Subroutines for enforcing defer_time limit: one to estimate how long a given object will take to transmit, and another to set the estimated bit rate based on how long the last transfer took. */ estimate_time: procedure (length_in_bits, time_needed); /**** returns the length in bits and expected time in seconds, factoring in overhead */ dcl length_in_bits fixed binary (35) parameter; dcl time_needed fixed binary (35) parameter; dcl code fixed binary (35); dcl quota_used fixed bin (18); if local_bof_command.object_type = SEGMENT then do; /* use current length */ call hcs_$status_long (local_bof_command.local_dirname, local_bof_command.local_ename, 1, addr (auto_status_branch), null (), code); if code ^= 0 & code ^= error_table_$no_s_permission then do; CANT_GET_LENGTH: call iodd_msg_ (LOG, MASTER, code, "", "Could not determine length of ^a.", local_full_pathname); length_in_bits = 0; time_needed = -1; return; end; else do; length_in_bits = BITS_PER_RECORD * auto_status_branch.current_length; /* current length rather than records_used because */ /* backup dumps zero pages */ time_needed = divide (length_in_bits, ds_ptr -> driver_status.bit_rate_est, 35, 0) + FILE_OVERHEAD; return; end; end; else do; call hcs_$quota_read (local_full_pathname, (0), (0), (""b), (""b), (0), quota_used, code); if code ^= 0 then go to CANT_GET_LENGTH; length_in_bits = BITS_PER_RECORD * quota_used; time_needed = divide (length_in_bits, ds_ptr -> driver_status.bit_rate_est, 35, 0) + FILE_OVERHEAD * divide (quota_used, EST_RECORDS_PER_FILE, 18, 0); return; end; %page; revise_time_estimate: entry (length_in_bits); dcl factor float bin int static options (constant) init (0.75e0); /* smoothing factor for rate estimate */ /**** Uses the time taken by the segment just transmitted to revise the estimate of the bit rate. */ old_rate = ds_ptr -> driver_status.bit_rate_est; if time_taken < 1 /* taking no chances */ then new_rate = old_rate; else new_rate = divide (length_in_bits, time_taken, 17, 0); if old_rate > 0 then new_rate = fixed (old_rate * factor + new_rate * (1e0 - factor)); ds_ptr -> driver_status.bit_rate_est = new_rate; return; end estimate_time; %page; /**** Represents the null entry value: if called, the current request is aborted */ nulle: procedure () options (variable); call abort_request_notify (FLUSH_REQUEST, NO_ERROR, "Backup system requested tape label."); return; end nulle; %page; /* Parameters */ dcl P_data_iocb_ptr pointer parameter; /* -> IOCB over which file is transmitted */ dcl P_stat_p pointer parameter; /* -> caller's iodd_static */ dcl P_imft_driver_info_ptr pointer parameter; /* -> description of the IMFT driver */ dcl P_code fixed binary (35) parameter; dcl P_condition_name character (*) parameter; /* abort_running_request: condition detected */ /* Remaining declarations */ dcl data_iocb_ptr pointer; /* -> I/O switch for file transmission */ dcl code fixed binary (35); dcl ignore_code fixed binary (35); dcl ignore_fb2 fixed binary (2); dcl ignore_fb21 fixed binary (21); dcl new_rate fixed binary (35); dcl old_rate fixed binary (35); dcl foreign_system_version float binary; dcl 1 local_icri aligned like icri automatic; dcl 1 local_bof_command aligned like bof_command; dcl 1 local_eof_command aligned like eof_command; dcl 1 local_abort_command aligned like abort_command; dcl 1 local_rr aligned like remote_request; dcl 1 ios_status aligned, /* for calling ios_$* */ 2 code fixed binary (35), /* actual error code */ 2 io_status bit (36); /* status bits from last I/O operation */ dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl input_buffer character (2048); /* for reading replies */ dcl notify_msg_buffer character (2048); /* for construction user notifications */ dcl ds_ptr pointer; /* -> driver_status structure */ dcl rd_ptr pointer; /* -> request_descriptor for this request */ dcl errfile_ptr pointer; /* -> error file generated by backup */ dcl errfile_attached bit (1) aligned; /* ON => error file is setup */ dcl allow_delete bit (1); /* ON => turned off if no access to delete object */ dcl deleting_object bit (1) static; /* ON => in process of deleting object after transfer */ dcl send_abort_command bit (1) aligned; /* ON => something has been sent to foreign system */ dcl backup_errors_detected bit (1) aligned; /* ON => some errors occured in backup_dump_ */ dcl foreign_backup_errors bit (1) aligned; /* ON => foreign system reported errors in backup_load_ */ dcl mail_destination character (32); /* user to receive notifications */ dcl mail_access_class bit (72) aligned; dcl (local_full_pathname, foreign_full_pathname) character (168); dcl foreign_system_name character (32) varying; dcl local_bit_count fixed binary (24); dcl source_full_pathname character (168); dcl target_full_pathname character (168); dcl local_notify bit (1) aligned; dcl local_request_number fixed binary (35); dcl time_needed_to_transmit fixed binary (35); /* number of seconds it would take to transmit this object */ dcl time_pict picture "zzz9v.9"; /* minutes of transmit time */ dcl time_started fixed binary (71); /* clock time at start of transmission */ dcl time_taken fixed binary (35); /* number of seconds it took to tranmsit current object */ dcl object_length fixed bin (35); /* length of object in bits */ dcl 1 auto_status_branch aligned like status_branch; dcl 1 imft_chk_acl aligned like imft_check_acl; dcl my_group_id character (32); dcl current_ring fixed binary (3); dcl IMFT_TRANSMIT_OBJECT_ character (32) static options (constant) initial ("imft_transmit_object_"); dcl BAD_CHK_OBJ_ACL_STR character (46) init ("Attempted to call imft_util_$check_object_acl") internal static options (constant); dcl NO_ERROR fixed binary (35) internal static options (constant) initial (0); dcl ONE_MINUTE fixed binary static options (constant) initial (60); dcl ONE_MILLION fixed binary (35) static options (constant) initial (1000000); dcl BITS_PER_RECORD fixed binary (35) static options (constant) initial (36 * 1024); dcl FILE_OVERHEAD fixed binary static options (constant) initial (10); /* assume 10 seconds per file */ dcl EST_RECORDS_PER_FILE fixed binary static options (constant) initial (3); /* for guessing how many files there are in a */ /* subtree based on quota */ dcl MINIMUM_TIME_TO_AVERAGE fixed binary static options (constant) initial (30); /* if it took less than a half minute, don't */ /* use it for estimate */ dcl KEEP_REQUEST bit (1) aligned static options (constant) initial ("1"b); /* keep the request in the queue */ dcl FLUSH_REQUEST bit (1) aligned static options (constant) initial ("0"b); /* flush the request from the queue */ dcl USER_REQ_DEF_OR_TERM character (73) init ("Request ^[deferred^;terminated^]: ^[^a^/^2x^;^s^]^a^/^2x(^[^a^s^;^s^a^])") internal static options (constant); dcl first_call bit (1) aligned static initial ("1"b); dcl 1 static_backup_control aligned static, /* control structure for backup_dump_ */ 2 header like backup_control.header, /* ... global data */ 2 object like backup_control.requests; /* ... the actual object to be dumped */ dcl accessfile_bc fixed bin (24); dcl accessfile_ename char (32) static; dcl accessfile_lth fixed bin (21); dcl accessfile_path char (168) static; dcl accessfile_ptr pointer; dcl afs_ptr pointer; dcl abort_message character (100); dcl code_message character (100) aligned; dcl errfile_ename character (32) static; dcl errfile_pathname character (168) static; dcl mail_subject character (1024) varying; dcl process_dname character (168) static; /* name of process directory which holds files for */ /* access errors and hierarchy dump errors */ dcl shortinfo character (8) aligned; dcl abort_request_label label static; /* used by driver's any_other handler */ dcl condition_name character (32) static; /* condition causing request to abort */ dcl error_table_$fatal_error fixed binary (35) external; dcl error_table_$moderr fixed binary (35) external; dcl error_table_$no_s_permission fixed binary (35) external; dcl error_table_$unimplemented_version fixed binary (35) external; dcl error_table_$user_not_found fixed binary (35) external; dcl imft_et_$reply_pending fixed binary (35) external; dcl imft_et_$timeout fixed binary (35) external; dcl backup_dump_ entry (pointer, fixed binary (35)); dcl convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned); dcl cu_$arg_list_ptr entry () returns (pointer); dcl delete_$path entry (char (*), char (*), bit (36), char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry () returns (character (32)); dcl get_pdir_ entry () returns (character (168)); dcl get_ring_ entry () returns (fixed binary (3)); dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$quota_read entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35)); dcl hcs_$initiate_count entry (character (*), character (*), character (*), fixed binary (24), fixed binary (2), pointer, fixed binary (35)); dcl hcs_$make_seg entry (character (*), character (*), character (*), fixed binary (5), pointer, fixed binary (35)); dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (character (*), character (*), fixed binary (1), fixed binary (2), fixed binary (24), fixed binary (35)); dcl hcs_$set_bc entry (character (*), character (*), fixed binary (24), fixed binary (35)); dcl hcs_$terminate_noname entry (pointer, fixed binary (35)); dcl hcs_$truncate_file entry (character (*), character (*), fixed binary (19), fixed binary (35)); dcl imft_convert_status_code_$decode entry (fixed binary (35)) returns (fixed binary (35)); dcl imft_convert_status_code_$encode entry (fixed binary (35)) returns (fixed binary (35)); dcl imft_mail_interface_$deliver_message entry (character (*), character (*), fixed binary, character (*), character (*), bit (72) aligned, fixed binary (35)); dcl imft_util_$check_object_acl entry (ptr, fixed bin (35)); dcl imft_util_$check_subtree_acl entry (ptr, fixed bin (35)); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1)); dcl ioa_$rsnnl entry () options (variable); dcl iodd_msg_ entry () options (variable); dcl ios_$attach entry (character (*), character (*), character (*), character (*), 1 aligned like ios_status); dcl ios_$detach entry (character (*), character (*), character (*), 1 aligned like ios_status); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl term_$refname entry (character (*), fixed binary (35)); dcl unique_chars_ entry (bit (*)) returns (character (15)); dcl (cleanup, daemon_again, daemon_again_slave, daemon_cancel, daemon_defer, daemon_kill, daemon_save, imft_debug_, imft_remote_logout_, imft_resynchronize_driver_, imft_write_abort_, record_quota_overflow) condition; dcl (addr, clock, convert, currentsize, divide, fixed, float, hbound, ltrim, length, max, null, rtrim, string, substr, unspec) builtin; %page; %include access_mode_values; %page; %include acl_structures; %page; %include backup_control; %page; %include delete_options; %page; %include driver_status; %page; %include fs_star_; %page; %include "_imft_check_acl"; %page; %include "_imft_cri"; %page; %include "_imft_driver_info"; %page; %include "_imft_ft_request"; %page; %include "_imft_ft_commands"; %page; %include "_imft_std_commands"; %page; %include iod_tables_hdr; %page; %include iodd_msg_constants; %page; %include iodd_static; %page; %include mlsys_deliver_info; %page; %include mseg_message_info; %page; %include queue_msg_hdr; %page; %include request_descriptor; %page; %include status_structures; %page; %include star_structures; end imft_transmit_object_;  imft_tty_.pl1 11/14/88 1517.9rew 11/14/88 1510.8 211455 /****^ ******************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * ******************************************** */ /* This I/O module is for data transfer between IMFT and a communications channel being managed by tty_. It converts between IMFT logical records and stream data in 8-bit characters. */ /* Written January 1983 by Robert Coren */ /* Modified: June 1983 by Robert Coren to requote attach options when building attach description */ /****^ HISTORY COMMENTS: 1) change(87-11-15,Oke), approve(88-08-01,MCR7948), audit(88-10-11,Farley), install(88-10-14,MR12.2-1165): Add support for in_dial/out_dial drivers by adding imft_tty_(get_line put_chars) entries. Also add debug code. 2) change(88-11-10,Beattie), approve(88-08-01,PBF7948), audit(88-11-14,Farley), install(88-11-14,MR12.2-1214): Changed version check to be independent of debug_output to catch unexpected IO traffic from causing trouble later on. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,^ifthendo */ imft_tty_: procedure; return; /* not an entry point */ /* attach a switch for communication between imft and tty_ */ imft_tty_attach: entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code); iocb_ptr = P_iocb_ptr; loud_sw = P_loud_sw; code = 0; iad_ptr = null (); /* avoid freeing garbage if I/O switch already attached */ if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do; P_code = error_table_$not_detached; if loud_sw then call com_err_ (P_code, IMFT_TTY_, "For switch ^a.", iocb_ptr -> iocb.name); return; end; system_area_ptr = get_system_free_area_ (); on condition (cleanup) call cleanup_attachment (ignore_code); allocate iad in (system_area) set (iad_ptr); iad.terminal_iocb_ptr = null (); /* keeps cleanup handler happy */ iad.record_buffer_ptr = null (); iad.attach_description = ""; iad.open_description = ""; do arg_index = lbound (P_attach_options, 1) to hbound (P_attach_options, 1); iad.attach_description = iad.attach_description || " " || requote_string_ ((P_attach_options (arg_index))); end; terminal_switch_name = "tty_" || "." || rtrim (iocb_ptr -> iocb.name); terminal_attach_desc = "tty_" || iad.attach_description; /* note that iad.attach_description already has leading space */ call iox_$attach_ioname (terminal_switch_name, iad.terminal_iocb_ptr, terminal_attach_desc, code); if code ^= 0 then call abort_attachment (code, "Unable to attach channel via: ^a", terminal_attach_desc); size_of_unpacked_header = divide (36 * size (imft_logical_record_header) + 7, 8, 17, 0); max_record_length = 4 * size (imft_logical_record_header) + IMFT_MAX_RECORD_LENGTH; /* this is maximum length of real record */ max_record_length = divide (9 * max_record_length + 7, 8, 21, 0); /* this is unpacked maximum length as we might have to read or write it */ allocate record_buffer in (system_area) set (iad.record_buffer_ptr); /* Mask and complete construction of the IOCB */ ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (MASK_OFF, ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = addr (iad.attach_description); iocb_ptr -> iocb.attach_data_ptr = iad_ptr; iocb_ptr -> iocb.open = imft_tty_open; iocb_ptr -> iocb.detach_iocb = imft_tty_detach; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); RETURN_FROM_ATTACH: P_code = code; return; %page; /* Open an I/O switch for file transfer */ imft_tty_open: entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; open_mode = P_open_mode; input_allowed, output_allowed = "0"b; /* we don't know about either yet */ if open_mode = Sequential_input then do; tty_open_mode = Stream_input; input_allowed = "1"b; end; else if open_mode = Sequential_output then do; tty_open_mode = Stream_output; output_allowed = "1"b; end; else if open_mode = Sequential_input_output then do; tty_open_mode = Stream_input_output; input_allowed, output_allowed = "1"b; end; else do; P_code = error_table_$bad_mode; return; end; call iox_$open (iad.terminal_iocb_ptr, tty_open_mode, "0"b, P_code); if P_code ^= 0 then return; call iox_$modes (iad.terminal_iocb_ptr, "force,init,rawi,rawo,^blk_xfer,^breakall,^iflow,^oflow,^no_outp,8bit", old_modes, ignore_code); /* This allows us to use 8-bit characters */ iad.open_description = rtrim (iox_modes (open_mode)); ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (MASK_OFF, ips_mask); iocb_ptr -> iocb.get_line = imft_tty_get_line; iocb_ptr -> iocb.put_chars = imft_tty_put_chars; if input_allowed then iocb_ptr -> iocb.read_record = imft_tty_read_record; if output_allowed then iocb_ptr -> iocb.write_record = imft_tty_write_record; iocb_ptr -> iocb.control = imft_tty_control; iocb_ptr -> iocb.modes = imft_tty_modes; iocb_ptr -> iocb.close = imft_tty_close; iocb_ptr -> iocb.detach_iocb = imft_tty_detach; iocb_ptr -> iocb.open_descrip_ptr = addr (iad.open_description); /* it's now open */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = 0; return; %page; /* Close an I/O switch used for file transfer */ imft_tty_close: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; code = 0; if iocb_ptr -> iocb.open_descrip_ptr = null () then do; P_code = error_table_$not_open; return; end; call iox_$close (iad.terminal_iocb_ptr, code); if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0; ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (MASK_OFF, ips_mask); iocb_ptr -> iocb.open_descrip_ptr = null (); iocb_ptr -> iocb.open = imft_tty_open; iocb_ptr -> iocb.detach_iocb = imft_tty_detach; iocb_ptr -> iocb.control, iocb_ptr -> iocb.modes, iocb_ptr -> iocb.read_record, iocb_ptr -> iocb.write_record = iox_$err_no_operation; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = code; return; %page; /* Detach an I/O switch from file transfer */ imft_tty_detach: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr; code = 0; if iocb_ptr -> iocb.attach_descrip_ptr = null () then do; P_code = error_table_$not_attached; return; end; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; system_area_ptr = get_system_free_area_ (); iad_ptr = iocb_ptr -> iocb.attach_data_ptr; call cleanup_attachment (code); ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (MASK_OFF, ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = null (); /* it's detached */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = code; /* in case trouble freeing the channel */ return; %page; /* Perform control operations on an I/O switch attached for file transfer */ imft_tty_control: entry (P_iocb_ptr, P_order, P_info_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; call iox_$control (iad.terminal_iocb_ptr, P_order, P_info_ptr, P_code); /* just pass all orders on */ return; %skip (10); /* Change modes: no modes are supported */ imft_tty_modes: entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; P_old_modes = ""; /* no modes are reflected to caller */ if P_new_modes = "" then P_code = 0; else P_code = error_table_$bad_mode; return; %page; /* Get a character line from the basic connection. Used for protocol setup in the out_dial connection. */ imft_tty_get_line: entry (P_iocb_ptr, P_buffer_ptr, P_buffer_max_length, P_data_lth, P_code); iocb_ptr = P_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; call iox_$get_line (iad.terminal_iocb_ptr, P_buffer_ptr, P_buffer_max_length, P_data_lth, P_code); if debug_output then call debug_out ("get_line", P_buffer_ptr, (P_data_lth)); return; %skip (10); /* Put a character string to the basic connection. Used for potocol setup in the out_dial connection, and a prompt on the in_dial connection. */ imft_tty_put_chars: entry (P_iocb_ptr, P_buffer_ptr, P_data_lth, P_code); iocb_ptr = P_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; call iox_$put_chars (iad.terminal_iocb_ptr, P_buffer_ptr, P_data_lth, P_code); if debug_output then call debug_out ("put_chars", P_buffer_ptr, (P_data_lth)); return; %page; /* given an IMFT logical record, write it in stream mode, unpacked if necessary */ imft_tty_write_record: entry (P_iocb_ptr, P_record_ptr, P_record_length, P_code); iocb_ptr = P_iocb_ptr; ilr_ptr = P_record_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; buffer_ptr = iad.record_buffer_ptr; /* header first, which is always binary, and so needs to be unpacked */ call unpack (ilr_ptr, buffer_ptr, 4 * size (imft_logical_record_header), unpacked_bytes); if imft_logical_record.version ^= IMFT_LOGICAL_RECORD_VERSION_1 then do; if debug_output then do; call ioa_ ("Version Sent: ^a^/Version Desired: ^a", imft_logical_record.version, IMFT_LOGICAL_RECORD_VERSION_1); call debug_out ("write_record (header)", ilr_ptr, 4 * size (imft_logical_record_header)); call debug_out ("unpacked header", buffer_ptr, (unpacked_bytes)); end; P_code = error_table_$unimplemented_version; return; end; call iox_$put_chars (iad.terminal_iocb_ptr, buffer_ptr, unpacked_bytes, P_code); if debug_output then call debug_out ("write_record (header)", buffer_ptr, (unpacked_bytes)); if P_code ^= 0 then return; if imft_logical_record.length > 0 then do; if imft_logical_record.binary then do; /* have to unpack it */ call unpack (addr (imft_logical_record.contents), buffer_ptr, imft_logical_record.length, unpacked_bytes); call iox_$put_chars (iad.terminal_iocb_ptr, buffer_ptr, unpacked_bytes, P_code); if debug_output then call debug_out ("write_record (binary body)", buffer_ptr, (unpacked_bytes)); end; else do; call iox_$put_chars (iad.terminal_iocb_ptr, addr (imft_logical_record.contents), imft_logical_record.length, P_code); if debug_output then call debug_out ("write_record (char body)", addr (imft_logical_record.contents), (imft_logical_record.length)); end; end; return; %page; /* read characters from the switch and put them into a logical record to return to the caller */ imft_tty_read_record: entry (P_iocb_ptr, P_record_ptr, P_max_length, P_record_length, P_code); iocb_ptr = P_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; ilr_ptr = P_record_ptr; buffer_ptr = iad.record_buffer_ptr; if P_max_length < 4 * size (imft_logical_record_header) then do; /* can't even hold header, this is absurd */ code = error_table_$smallarg; /* long_record would give the wrong idea */ return; end; /* read the header first -- it always has to be packed */ chars_read = 0; do while (chars_read < size_of_unpacked_header); call iox_$get_chars (iad.terminal_iocb_ptr, addcharno (buffer_ptr, chars_read), size_of_unpacked_header - chars_read, chars_read_this_time, P_code); if P_code ^= 0 then return; chars_read = chars_read + chars_read_this_time; end; if debug_output then call debug_out ("read_record (header)", buffer_ptr, (chars_read)); call pack (buffer_ptr, ilr_ptr, (size_of_unpacked_header), size_of_packed_header); if imft_logical_record.version ^= IMFT_LOGICAL_RECORD_VERSION_1 then do; if debug_output then do; call ioa_ ("Version Received: ^a^/Version Desired: ^a", imft_logical_record.version, IMFT_LOGICAL_RECORD_VERSION_1); call debug_out ("read_record (header)", buffer_ptr, (chars_read)); call debug_out ("packed header", ilr_ptr, (chars_read / 8) * 9); end; P_code = error_table_$unimplemented_version; return; end; if imft_logical_record.length = 0 then do; /* record consists of header only */ P_record_length = 4 * size (imft_logical_record_header); return; end; room_left = P_max_length - size_of_packed_header; chars_read = 0; if imft_logical_record.binary then do; /* we'll have to pack the rest, too */ raw_chars_read = 0; chars_to_read = divide (9 * imft_logical_record.length + 7, 8, 21, 0); max_unpacked_chars = divide (9 * room_left + 7, 8, 21, 0); actual_limit = min (chars_to_read, max_unpacked_chars); do while (raw_chars_read < actual_limit); call iox_$get_chars (iad.terminal_iocb_ptr, addcharno (buffer_ptr, raw_chars_read), actual_limit - raw_chars_read, chars_read_this_time, P_code); if P_code ^= 0 then return; if raw_chars_read + chars_read_this_time > max_unpacked_chars then do; chars_read_this_time = max_unpacked_chars - raw_chars_read; P_code = error_table_$long_record; end; raw_chars_read = raw_chars_read + chars_read_this_time; end; if debug_output then call debug_out ("read_record (binary body)", buffer_ptr, (raw_chars_read)); call pack (buffer_ptr, addr (imft_logical_record.contents), raw_chars_read, chars_read); end; else do; /* not binary data, doesn't need packing */ chars_to_read = imft_logical_record.length; do while (chars_read < imft_logical_record.length & room_left > 0); n_chars = min (chars_to_read, room_left); call iox_$get_chars (iad.terminal_iocb_ptr, addcharno (addr (imft_logical_record.contents), chars_read), n_chars, chars_read_this_time, P_code); if P_code ^= 0 then return; chars_read = chars_read + chars_read_this_time; chars_to_read = chars_to_read - chars_read_this_time; room_left = room_left - chars_read_this_time; end; if chars_read < imft_logical_record.length then P_code = error_table_$long_record; end; if debug_output then call debug_out ("read_record (char body)", addr (imft_logical_record.contents), (chars_read)); P_record_length = 4 * size (imft_logical_record_header) + chars_read; return; %page; /* pair of subroutines for converting between 8 bits/byte and 9 bits/byte */ pack_unpack: procedure; return; /* not to be called */ dcl packed_byte_ptr pointer parameter; dcl unpacked_byte_ptr pointer parameter; dcl P_input_length fixed bin (21) parameter; dcl P_output_length fixed bin (21) parameter; dcl unpacked_length fixed bin; dcl packed_bytes (unpacked_length) bit (8) unaligned based (packed_byte_ptr); dcl unpacked_bytes (unpacked_length) bit (9) unaligned based (unpacked_byte_ptr); pack: entry (unpacked_byte_ptr, packed_byte_ptr, P_input_length, P_output_length); /* input has high-order bit of every 9 off, + 8 data bits; pack it into binary */ unpacked_length = P_input_length; P_output_length = divide (8 * unpacked_length, 9, 21, 0); packed_bytes = substr (unpacked_bytes, 2); /* simple as that! */ return; unpack: entry (packed_byte_ptr, unpacked_byte_ptr, P_input_length, P_output_length); /* input is binary; unpack it so that high-order bit of every 9 is 0 */ P_output_length, unpacked_length = divide (9 * P_input_length + 7, 8, 21, 0); string (unpacked_bytes) = ""b; substr (unpacked_bytes, 2) = packed_bytes; /* it works in this direction, too */ return; end pack_unpack; %page; /* Cleanup whatever portion of an attachment exists */ cleanup_attachment: procedure (P_code); dcl P_code fixed binary (35) parameter; /* a parameter to allow callers to ignore it */ P_code = 0; if iad_ptr ^= null () then do; /* there is an I/O switch */ if iad.terminal_iocb_ptr ^= null () then do; call iox_$close (iad.terminal_iocb_ptr, ignore_code); call iox_$detach_iocb (iad.terminal_iocb_ptr, P_code); call iox_$destroy_iocb (iad.terminal_iocb_ptr, ignore_code); iad.terminal_iocb_ptr = null (); end; if iad.record_buffer_ptr ^= null () then free iad.record_buffer_ptr -> record_buffer in (system_area); free iad in (system_area); iad_ptr = null (); end; return; end cleanup_attachment; %page; /* Wrapper to protect against errors while IPS interrupts are masked */ any_other_handler: procedure () options (non_quick); if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask); ips_mask = ""b; call continue_to_signal_ (ignore_code); /* not interested, */ return; end any_other_handler; /* Abort a call to the attach entry: print an error message if requested */ abort_attachment: procedure () options (variable, non_quick); dcl the_code fixed binary (35) based (the_code_ptr); dcl the_code_ptr pointer; dcl caller_message character (256); call cu_$arg_ptr (1, the_code_ptr, ignore_fb21, ignore_code); if loud_sw then do; /* an error message is requested */ call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, ignore_fb21, "1"b, "0"b); call com_err_ (the_code, IMFT_TTY_, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message); end; call cleanup_attachment (ignore_code); /* get rid of anything that was accomplished */ if the_code = 0 then code = error_table_$action_not_performed; else code = the_code; /* save the error code */ go to RETURN_FROM_ATTACH; end abort_attachment; %page; debug_out: proc (me, buf_ptr, buf_len); dcl me char (*); dcl buf_ptr ptr; dcl buf_len fixed bin; dcl str char (buf_len) unaligned based (buf_ptr); dcl stb bit (buf_len * 9) unaligned based (buf_ptr); call ioa_ ("^a(^i) ^p: ""^a""", me, buf_len, buf_ptr, str); call ioa_ ("^vb", buf_len * 9, stb); end debug_out; %skip (4); dcl debug_output bit (1) static initial ("0"b); debug_list: entry; debug_output = "1"b; return; %page; dcl P_buffer_max_length fixed bin (21) parameter; /* max length of IO */ dcl P_buffer_ptr pointer parameter; /* -> buffer */ dcl P_data_lth fixed bin (21) parameter; /* length of IO */ dcl P_iocb_ptr pointer parameter; /* -> IOCB */ dcl P_attach_options (*) character (*) varying parameter; /* attach: attachment arguments */ dcl P_loud_sw bit (1) parameter; /* attach: ON => attachment errors should call com_err_ */ dcl P_open_mode fixed binary parameter; /* open: opening mode */ dcl P_open_sw bit (1) parameter; /* open: obsolete parameter */ dcl P_record_ptr pointer parameter; /* (read write)_record: -> record */ dcl P_record_length fixed bin (21) parameter; /* read_record: actual length of record read */ /* write_record: length of record to be written */ dcl P_max_length fixed bin (21) parameter; /* read_record: length of caller-supplied buffer */ dcl P_code fixed bin (35); /* status code */ dcl P_order character (*) parameter; /* control: name of control order to be performed */ dcl P_info_ptr pointer parameter; /* control: -> additional information required to execute the control order */ dcl P_new_modes character (*) parameter; /* modes: new modes to be set */ dcl P_old_modes character (*) parameter; /* modes: set to modes in effect before change */ /* Local copies of parameters */ dcl iocb_ptr pointer; dcl code fixed binary (35); dcl ignore_code fixed binary (35); dcl ignore_fb21 fixed binary (21); dcl loud_sw bit (1) aligned; dcl open_mode fixed binary; /* other declarations */ /* AUTOMATIC */ dcl system_area area aligned based (system_area_ptr); dcl system_area_ptr pointer; dcl arg_index fixed binary; /* # of attach option being processed */ dcl terminal_attach_desc character (512); dcl terminal_switch_name character (32); dcl iad_ptr pointer; dcl max_record_length fixed bin (21); dcl tty_open_mode fixed bin; dcl input_allowed bit (1); dcl output_allowed bit (1); dcl old_modes char (256); dcl unpacked_bytes fixed bin (21); dcl chars_read fixed bin (21); dcl chars_read_this_time fixed bin (21); dcl size_of_packed_header fixed bin (21); dcl room_left fixed bin (21); dcl raw_chars_read fixed bin (21); dcl chars_to_read fixed bin (21); dcl max_unpacked_chars fixed bin (21); dcl n_chars fixed bin (21); dcl buffer_ptr pointer; dcl actual_limit fixed bin; dcl ips_mask bit (36); /* BASED */ dcl record_buffer char (max_record_length) based; dcl 1 iad based (iad_ptr) aligned, 2 attach_description char (1024) varying, 2 open_description char (24) varying, 2 terminal_iocb_ptr pointer, 2 record_buffer_ptr pointer; /* ENTRIES */ dcl com_err_ entry () options (variable); dcl continue_to_signal_ entry (fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$reset_ips_mask entry (bit (36), bit (36)); dcl hcs_$set_ips_mask entry (bit (36), bit (36)); dcl ioa_ entry () options (variable); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1)); dcl iox_$attach_ioname entry (character (*), pointer, character (*), fixed binary (35)); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl iox_$close entry (pointer, fixed binary (35)); dcl iox_$destroy_iocb entry (pointer, fixed binary (35)); dcl iox_$detach_iocb entry (pointer, fixed binary (35)); dcl iox_$err_no_operation entry () options (variable); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35)); dcl iox_$propagate entry (pointer); dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl requote_string_ entry (char (*)) returns (char (*)); /* EXTERNAL STATIC */ dcl ( error_table_$action_not_performed, error_table_$bad_mode, error_table_$long_record, error_table_$not_attached, error_table_$not_closed, error_table_$not_detached, error_table_$not_open, error_table_$smallarg, error_table_$unimplemented_version ) fixed bin (35) external static; /* INTERNAL STATIC */ dcl IMFT_TTY_ character (32) static options (constant) initial ("imft_tty_"); dcl MASK_OFF bit (36) init ((36)"0"b) internal static options (constant); dcl size_of_unpacked_header fixed bin internal static; /* BUILTINS & CONDITIONS */ dcl (addcharno, addr, divide, hbound, lbound, min, null, rtrim, size, string, substr) builtin; dcl (any_other, cleanup) condition; %page; %include iocb; %page; %include iox_modes; %page; %include imft_logical_record; end imft_tty_;  imft_util_.pl1 10/27/88 1310.7rew 10/27/88 1309.4 174465 /****^ ******************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * ******************************************** */ /* format: style1,^inddcls,insnl,delnl,indend,indnoniterend,indbeginend,indthenbeginend,tree,^case */ /****^ HISTORY COMMENTS: 1) change(88-08-11,Beattie), approve(88-08-01,MCR7948), audit(88-10-11,Farley), install(88-10-14,MR12.2-1165): Created to support IMFT access checking. 2) change(88-10-26,Beattie), approve(88-08-01,PBF7948), audit(88-10-27,Farley), install(88-10-27,MR12.2-1195): Changed check_object_acl entry to be able to chase nonstar links. END HISTORY COMMENTS */ imft_util_: procedure; return; /* not an entry point */ check_object_acl: entry (p_check_acl_ptr, p_code); ME = "imft_util_$check_object_acl"; checking_subtree = "0"b; afs_ptr = null (); star_optionsP = null (); on cleanup call CLEANUP (); call init_check_acl (); star_paths.value (1) = pathname_ ((imft_check_acl.dirname), (imft_check_acl.ename)); star_options.entry_type.links = ENTRY_RETURN | ENTRY_CHASE_NONSTAR_LINKS; star_options.entry_type.dirs = ENTRY_RETURN | ENTRY_DONT_LIST_SUBENTRIES; go to COMMON; check_subtree_acl: entry (p_check_acl_ptr, p_code); ME = "imft_util_$check_subtree_acl"; checking_subtree = "1"b; afs_ptr = null (); star_optionsP = null (); on cleanup call CLEANUP (); call init_check_acl (); /**** Set up file to collect error messages */ call expand_pathname_ ((imft_check_acl.accessfile_pathname), accessfile_dname, accessfile_ename, ignore_code); call hcs_$truncate_file (accessfile_dname, accessfile_ename, 0, ignore_code); call hcs_$set_bc (accessfile_dname, accessfile_ename, 0, ignore_code); call ioa_$rsnnl ("vfile_ ^a -extend -ssf", attach_desc, message_len, accessfile_pathname); call iox_$find_iocb ("accessfile_switch", afs_ptr, code); if code ^= 0 then do; call convert_status_code_ (code, shortinfo, longinfo); call ioa_$rsnnl ("Tried to find an IOCB for accessfile switch.^/(^a)", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, longinfo); p_code = code; go to BAIL_OUT; end; call iox_$attach_ptr (afs_ptr, attach_desc, (null ()), code); if code ^= 0 then do; call convert_status_code_ (code, shortinfo, longinfo); call ioa_$rsnnl ("Tried to attach vfile_ to ^a^/(^a)", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, accessfile_pathname, longinfo); p_code = code; go to BAIL_OUT; end; call iox_$open (afs_ptr, Stream_output, "0"b, code); if code ^= 0 then do; call convert_status_code_ (code, shortinfo, longinfo); call ioa_$rsnnl ("Tried to open accessfile_switch to ^a^/(^a)", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, accessfile_pathname, longinfo); p_code = code; go to BAIL_OUT; end; star_paths.value (1) = pathname_ ((imft_check_acl.dirname), rtrim (imft_check_acl.ename) || ">**"); star_options.entry_type.links = ENTRY_DONT_RETURN; star_options.entry_type.dirs = ENTRY_RETURN | ENTRY_LIST_SUBENTRIES; COMMON: call fs_star_$select (star_optionsP, star_dataP, code); if code ^= 0 then do; imft_check_acl.allow_transfer = "0"b; call convert_status_code_ (code, shortinfo, longinfo); call ioa_$rsnnl ("^a: Error while checking access to objects in subtree.^/(^a)", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, ME, longinfo); p_code = code; go to BAIL_OUT; end; BAIL_OUT: call CLEANUP (); RETURN: return; %page; /**** This is called by fs_star_ for each object it was directed to find. */ check_fs_entry: proc (P_star_data_ptr, Pdir, Pent, Pcomp, Paction); dcl P_star_data_ptr pointer; dcl Pdir char (*); dcl Pent (*) char (32) parm; dcl Pcomp char (*) parm; dcl Paction fixed bin parm; dcl access_error bit (1); dcl code fixed bin (35); dcl local_dirname char (168); dcl local_ename char (32); dcl local_pathname char (168); dcl my_access_ok bit (1); dcl user_access_ok bit (1); star_dataP = P_star_data_ptr; local_dirname = Pdir; local_ename = Pent (1); local_pathname = pathname_ (local_dirname, local_ename); Paction = HANDLER_OK; /* unless a problem is found */ general_acl.status_code = 0; if ^checking_subtree /* let caller know what type object this is */ then imft_check_acl.type = star_data.type; /* unless checking a subtree */ %page; /**** Check ring brackets. */ if star_data.type = ENTRY_TYPE_DIRECTORY | star_data.type = ENTRY_TYPE_DM_FILE | star_data.type = ENTRY_TYPE_MSF then do; call hcs_$get_dir_ring_brackets (local_dirname, local_ename, dir_ring_brackets, code); if code = 0 then do; if ^checking_subtree then imft_check_acl.object_ring = dir_ring_brackets (1); if imft_check_acl.effective_ring > dir_ring_brackets (1) then code = error_table_$lower_ring; end; end; /* if star_data.type in set of directories */ else do; call hcs_$get_ring_brackets (local_dirname, local_ename, seg_ring_brackets, code); if code = 0 then do; if ^checking_subtree then imft_check_acl.object_ring = seg_ring_brackets (1); if imft_check_acl.effective_ring > seg_ring_brackets (1) then code = error_table_$lower_ring; end; end; /* if star_data.type not in set of directories */ if code ^= 0 then do; general_acl (imft_check_acl.bad_acl_idx).status_code = code; call set_error_message (); return; end; %page; /**** Check ACL of object. */ if star_data.type = ENTRY_TYPE_DIRECTORY then do; access_str = DIR_ACCESS_MODE_NAMES (bin (imft_check_acl.dir_access)); test_access = imft_check_acl.dir_access; end; else do; access_str = SEG_ACCESS_MODE_NAMES (bin (imft_check_acl.seg_access)); test_access = imft_check_acl.seg_access; end; call fs_util_$list_acl (local_dirname, local_ename, GENERAL_ACL_VERSION_1, null (), imft_check_acl.gen_acl_ptr, code); if code ^= 0 then do; imft_check_acl.error_code = code; call set_error_message (); return; end; access_error = "0"b; do acl_idx = 1 to hbound (general_acl.mode, 1); code = 0; if general_acl (acl_idx).status_code ^= 0 /* Person.Project is not present */ then code = general_acl (acl_idx).status_code; else if (general_acl (acl_idx).mode & test_access) ^= test_access /* explicitly denied access */ then general_acl (acl_idx).status_code, code = error_table_$moderr; imft_check_acl.bad_acl_idx = acl_idx; /* record current pass, it may be last one */ if code ^= 0 then call set_error_message (); end; /* loop on acl_idx */ if access_error then return; %page; /**** Check AIM of object. */ if imft_check_acl.check_aim then do; call hcs_$get_access_class (local_dirname, local_ename, local_obj_access_class, code); if code ^= 0 then do; call convert_status_code_ (code, shortinfo, longinfo); call ioa_$rsnnl ( "^[^/^]Access error: ^a^/Attempting to determine access class of^[^/^2x^a^; object.^]", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, checking_subtree, longinfo, checking_subtree, local_pathname); call process_error (); end; my_access_ok = aim_check_$greater_or_equal (imft_check_acl.sys_auth_ceiling, local_obj_access_class); if my_access_ok then my_access_ok = aim_check_$greater_or_equal (local_obj_access_class, imft_check_acl.sys_auth_floor); if ^my_access_ok then do; /* access class exceeds maximum allowed for transfer */ object_access_class_text, max_access_class_text = ""; call convert_authorization_$to_string_short (local_obj_access_class, object_access_class_text, ignore_code); call convert_authorization_$to_string_short (imft_check_acl.sys_auth_ceiling, max_access_class_text, ignore_code); call convert_authorization_$to_string_short (imft_check_acl.sys_auth_floor, min_access_class_text, ignore_code); imft_check_acl.bad_acl_idx = DRIVER_ACL_IDX; general_acl (DRIVER_ACL_IDX).status_code, code = error_table_$ai_restricted; call convert_status_code_ (code, shortinfo, longinfo); call ioa_$rsnnl ( "^[^/^]Access error: ^a^/^2xAccess class of object (^[^a^;^ssystem_low^]) is not within the range permitted for transfer to ^a (^[^a^;^ssystem_low^]:^[^a^;^ssystem_low^])^[^/^2x^a^;^s.^]", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, checking_subtree, longinfo, (object_access_class_text ^= ""), object_access_class_text, imft_check_acl.foreign_sys_name, (min_access_class_text ^= ""), min_access_class_text, (max_access_class_text ^= ""), max_access_class_text, checking_subtree, local_pathname) ; call process_error (); end; %page; /**** Check AIM of user with object. */ user_access_ok = aim_check_$greater_or_equal (imft_check_acl.user_auth, local_obj_access_class); if ^user_access_ok then do; /* AIM strikes again */ imft_check_acl.bad_acl_idx = USER_ACL_IDX; general_acl (USER_ACL_IDX).status_code, code = error_table_$ai_restricted; call convert_status_code_ (code, shortinfo, longinfo); user_authorization_text = ""; call convert_authorization_$to_string_short (imft_check_acl.user_auth, user_authorization_text, ignore_code); call ioa_$rsnnl ( "^[^/^]Access error: ^a^/^2x^a (at authorization ^[^a^;^ssystem_low^]) can not ^[examine^;read^]^[^/^2x^a^;^s object.^]", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, checking_subtree, longinfo, general_acl (USER_ACL_IDX).access_name, (user_authorization_text ^= ""), user_authorization_text, (star_data.type = ENTRY_TYPE_DIRECTORY), checking_subtree, local_pathname); call process_error (); end; if access_error then return; end; /* if imft_check_acl.check_aim */ imft_check_acl.objects_to_transfer = "1"b; return; %page; /**** This is called by fs_star_ to indicate that some error occured in accessing the indicated object. Any call to this routine is considered an access failure and the IMFT request is not to be processed. */ analyze_fs_error: entry (P_star_data_ptr, Pdir, Pent, Pcomp, Pcode, Pmessage, Paction); dcl Pcode fixed bin (35) parameter; dcl Pmessage char (*) parameter; dcl local_path char (168); Paction = ERROR_REJECT; code = Pcode; call convert_status_code_ (code, shortinfo, longinfo); if Pent (1) = "" then local_path = Pdir; else local_path = pathname_ (Pdir, Pent (1)); call ioa_$rsnnl ("^a: Error from fs_star_ ERROR handler while processing:^/^2x^a^/^2x^a^[^/^2x(^a)^]", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, ME, local_path, longinfo, (Pmessage ^= ""), Pmessage); call process_error (); return; %page; /**** Internal routine to set up an appropriate error message. */ set_error_message: proc; call convert_status_code_ (code, shortinfo, longinfo); bad_access_name = general_acl (imft_check_acl.bad_acl_idx).access_name; if substr (star_data.type, 1, 1) = "-" then object_type = substr (star_data.type, 2); else object_type = star_data.type; if code = error_table_$user_not_found then call ioa_$rsnnl ( "^[^/^]Access error: ^a^/^2xAn explicit ACL entry for ^[Driver^;User^] (^a)^[^/^2xmust appear on ^a^; must appear on object.^]", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, checking_subtree, longinfo, (imft_check_acl.bad_acl_idx = DRIVER_ACL_IDX), bad_access_name, checking_subtree, local_pathname); else if code = error_table_$moderr then call ioa_$rsnnl ( "^[^/^]Access error: ^a^/^2xAccess mode ^a must be given in ACL entry for ^[Driver^;User^] (^a)^[^/^2xwhich appears on ^a^; which appears on object.^]", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, checking_subtree, longinfo, access_str, (imft_check_acl.bad_acl_idx = DRIVER_ACL_IDX), bad_access_name, checking_subtree, local_pathname); else if code = error_table_$lower_ring then call ioa_$rsnnl ( "^[^/^]Access error: ^a^/^2xThe ^a object cannot be transfered because ring brackets less than user execution ring.^[^/^2x^a^]", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, checking_subtree, longinfo, object_type, checking_subtree, local_pathname); else call ioa_$rsnnl ( "^[^/^]Access error: ^a^/^2xDetermining driver (^a) and user (^a)^[^/^2xaccess to: ^a^; access to object.^]", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, checking_subtree, message_len, longinfo, general_acl (DRIVER_ACL_IDX).access_name, general_acl (USER_ACL_IDX).access_name, checking_subtree, local_pathname); call process_error (); end set_error_message; %page; /**** Internal routine to process error code and set up for return. */ process_error: proc; dcl buffer character (512); dcl iox_code fixed bin (35); Paction = HANDLER_DONT_EXPAND; access_error = "1"b; if checking_subtree then do; /* collect errors to send as mail */ buffer = imft_check_acl (imft_check_acl.bad_acl_idx).error_message; call iox_$put_chars (afs_ptr, addr (buffer), message_len, iox_code); if iox_code ^= 0 then do; call ioa_$rsnnl ("^a: Tried to write to ^a", imft_check_acl (imft_check_acl.bad_acl_idx).error_message, message_len, ME, imft_check_acl.accessfile_pathname); p_code = iox_code; go to BAIL_OUT; end; end; /* if checking_subtree */ if code ^= 0 then if code = error_table_$lower_ring then imft_check_acl.found_inner_ring_object = "1"b; else imft_check_acl.allow_transfer = "0"b; end process_error; end check_fs_entry; %page; init_check_acl: proc; imft_check_acl_ptr = p_check_acl_ptr; if imft_check_acl.version ^= IMFT_CHECK_ACL_VERSION_1 then do; /* cannot use this structure for error messages, etc */ /* caller will have to special case */ p_code = error_table_$unimplemented_version; go to RETURN; end; code, p_code = 0; /* for now */ call fs_star_$init (null (), ME, "", STAR_OPTIONS_VERSION_1, star_optionsP, code); if code ^= 0 then do; imft_check_acl.allow_transfer = "0"b; call convert_status_code_ (code, shortinfo, longinfo); call ioa_$rsnnl ("^a: Error from fs_star_$init: ^a", imft_check_acl.error_message, message_len, ME, longinfo); p_code = code; go to BAIL_OUT; end; star_paths.version = STAR_PATHS_VERSION_1; star_paths.count = 1; star_options.entry_type.segs = ENTRY_RETURN; star_options.entry_type.archives = ENTRY_RETURN; star_options.entry_type.msfs = ENTRY_RETURN; star_options.entry_type.msf_comps = ENTRY_DONT_RETURN; star_options.entry_type.dm_files = ENTRY_RETURN | ENTRY_INASE; star_options.entry_type.extended_entries = ENTRY_RETURN | ENTRY_INASE; star_options.entry_type.arch_comps = ENTRY_DONT_RETURN; star_options.extended_entry_typesP = null (); star_options.match_namesP = null (); star_options.exclude_namesP = null (); star_options.sorting = SORT_OFF; star_options.handler = check_fs_entry; star_options.error = analyze_fs_error; star_options.handler_dataP = null (); imft_check_acl.allow_transfer = "1"b; imft_check_acl.objects_to_transfer = "0"b; imft_check_acl.found_inner_ring_object = "0"b; imft_check_acl.error_code = 0; imft_check_acl.error_message = ""; acl_ptr = imft_check_acl.gen_acl_ptr; end init_check_acl; %page; CLEANUP: proc; if star_optionsP ^= null () then do; call fs_star_$term (star_optionsP); star_optionsP = null (); end; if afs_ptr ^= null () then do; call iox_$close (afs_ptr, ignore_code); call iox_$detach_iocb (afs_ptr, ignore_code); afs_ptr = null (); end; end CLEANUP; %page; dcl p_check_acl_ptr pointer parameter; dcl p_code fixed bin (35) parameter; dcl ME char (32); dcl access_str character (4); dcl accessfile_dname char (168) static; dcl accessfile_ename char (32) static; dcl acl_idx fixed bin; dcl addr builtin; dcl attach_desc char (80); dcl afs_ptr pointer; dcl bad_access_name character (32); dcl bin builtin; dcl checking_subtree bit (1); dcl cleanup condition; dcl code fixed binary (35); dcl dir_ring_brackets (2) fixed bin (3); dcl hbound builtin; dcl ignore_code fixed bin (35); dcl local_obj_access_class bit (72) aligned; dcl longinfo char (100) aligned; dcl max_access_class_text character (256); dcl message_len fixed bin (21); dcl min_access_class_text character (256); dcl null builtin; dcl object_access_class_text character (256); dcl object_type character (32); dcl rtrim builtin; dcl seg_ring_brackets (3) fixed bin (3); dcl shortinfo character (8) aligned; dcl substr builtin; dcl test_access bit (3); dcl user_authorization_text character (256); dcl error_table_$ai_restricted fixed bin (35) ext static; dcl error_table_$lower_ring fixed bin (35) ext static; dcl error_table_$moderr fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$user_not_found fixed bin (35) ext static; dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl fs_star_$init entry (ptr, char (*), char (*), char (8), ptr, fixed bin (35)); dcl fs_star_$select entry (ptr, ptr, fixed bin (35)); dcl fs_star_$term entry (ptr); dcl fs_util_$list_acl entry (char (*), char (*), char (*), ptr, ptr, fixed bin (35)); dcl hcs_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35)); dcl hcs_$get_dir_ring_brackets entry (char (*), char (*), (2) fixed bin (3), fixed bin (35)); dcl hcs_$get_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35)); dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl hcs_$truncate_file entry (char (*), char (*), fixed bin (19), fixed bin (35)); dcl ioa_$rsnnl entry () options (variable); dcl iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); %page; %include "_imft_check_acl"; %page; %include access_mode_values; %page; %include acl_structures; %page; %include fs_star_; %page; %include iox_modes; end imft_util_;  list_imft_requests.pl1 10/14/88 1248.7rew 10/14/88 1211.3 315063 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* Displays status of Inter-Multics File Transfer (IMFT) requests */ /* Created: April 1982 by G. Palter */ /* Modified: 16 July 1982 by G. Palter to rename "-entry_name" to "-entryname" */ /* Modified: March 1983 by Robert Coren to recognize "-source" and to list all queues by default */ /* Modified: February 23, 1984 by C. Marker to use version 5 message segments */ /****^ HISTORY COMMENTS: 1) change(88-07-02,Beattie), approve(88-08-01,MCR7948), audit(88-10-11,Farley), install(88-10-14,MR12.2-1165): Display new options: -delete, -extend and -update. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ list_imft_requests: lir: procedure () options (variable); dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl 1 local_sb aligned like status_branch; dcl 1 local_mmi aligned like mseg_message_info; dcl 1 message_ids (total_message_ids) aligned based (message_ids_ptr), 2 id bit (72), 2 position fixed binary, 2 pad bit (36); dcl message_ids_ptr pointer; dcl total_message_ids fixed binary; dcl argument character (argument_lth) unaligned based (argument_ptr); dcl id_qualifier character (id_qualifier_lth) unaligned based (id_qualifier_ptr); dcl (the_argument_list, argument_ptr, id_qualifier_ptr) pointer; dcl (argument_lth, id_qualifier_lth) fixed binary (21); dcl (n_arguments, id_qualifier_idx, argument_idx) fixed binary; dcl 1 n_selections aligned, 2 path fixed binary, /* # of pathname specifiers */ 2 entry fixed binary, /* # of -entry STR specifiers */ 2 id fixed binary; /* # of request ID specifiers */ dcl process_selections bit (1) aligned; dcl array_bound fixed binary; dcl request_type character (24); dcl foreign_system character (24); dcl remote bit (1) aligned; dcl (queue_indeces, total_requests, selected_requests, first_id_indeces) dimension (4) fixed binary; dcl (queue, default_queue, max_queues, queue_idx) fixed binary; dcl (generic_type, queue_string) character (32); dcl (opened_a_queue, all_queues_empty) bit (1) aligned; dcl (output_mode, path_output_mode, id_output_mode, position_mode, user_selection) fixed binary (2); dcl (user_id, person_id, project_id) character (32); dcl (match_any_person, match_any_project) bit (1) aligned; dcl a_dirname character (168); dcl an_ename character (32); dcl request_id_nonvarying character (19); dcl request_id character (19) varying; dcl access_required bit (36) aligned; dcl message_idx fixed binary; dcl first_message_in_queue bit (1) aligned; dcl code fixed binary (35); /* format: off */ dcl (DEFAULT initial (00b), /* default setting for control argument */ BRIEF initial (01b), /* -brief */ LONG initial (10b), /* -long */ NO_POSITION initial (01b), /* -no_position */ SHOW_POSITION initial (10b), /* -position */ TOTALS initial (11b), /* -totals */ USER initial (01b), /* -own */ SUBSET initial (10b), /* -user STR */ ALL initial (11b), /* -admin */ NONE initial (00b), /* not a selection control argument */ PATH initial (01b), /* pathname selection */ ENTRY initial (10b), /* -entry STR */ ID initial (11b)) /* -id STR */ fixed binary (2) static options (constant); dcl ( /* A_EXTENDED_ACCESS initial ("400000000000"b3),*/ O_EXTENDED_ACCESS initial ("040000000000"b3), R_EXTENDED_ACCESS initial ("100000000000"b3), S_EXTENDED_ACCESS initial ("020000000000"b3)) bit (36) aligned static options (constant); dcl STATE_UNKNOWN fixed binary static options (constant) initial (-1); dcl STATE_NAMES (-1:4) character (32) varying static options (constant) initial ( "unknown", "unprocessed", "deferred", "state changing", "eligible", "running"); /* format: on */ dcl CHASE fixed binary (1) static options (constant) initial (1); /* dcl READ_FIRST_MESSAGE bit (1) aligned static options (constant) initial ("0"b); dcl READ_THIS_MESSAGE bit (2) aligned static options (constant) initial ("00"b); */ dcl READ_NEXT_MESSAGE bit (2) aligned static options (constant) initial ("01"b); dcl LIST_IMFT_REQUESTS character (32) static options (constant) initial ("list_imft_requests"); dcl imft_data_$queue_dirname character (168) external; /* format: off */ dcl (error_table_$bad_segment, error_table_$badopt, error_table_$id_not_found, error_table_$inconsistent, error_table_$moderr, error_table_$no_message, error_table_$no_s_permission, error_table_$noarg) fixed binary (35) external; /* format: on */ dcl check_star_name_$entry entry (character (*), fixed binary (35)); dcl com_err_ entry () options (variable); dcl cu_$arg_count entry (fixed binary, fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl date_time_ entry (fixed binary (71), character (*)); dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); dcl get_group_id_ entry () returns (character (32)); dcl get_system_free_area_ entry () returns (pointer); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl hcs_$status_long entry (character (*), character (*), fixed binary (1), pointer, pointer, fixed binary (35)); dcl imft_default_rqt_ entry () returns (char (*)); dcl ioa_ entry () options (variable); dcl iod_info_$generic_type entry (character (*), character (32), fixed binary (35)); dcl iod_info_$queue_data entry (character (*), fixed binary, fixed binary, fixed binary (35)); dcl match_request_id_ entry (fixed binary (71), character (*)) returns (bit (1) aligned); dcl match_star_name_ entry (character (*), character (*), fixed binary (35)); dcl message_segment_$close entry (fixed binary, fixed binary (35)); dcl message_segment_$get_message_count_index entry (fixed binary, fixed binary, fixed binary (35)); dcl message_segment_$get_mode_index entry (fixed binary, bit (36) aligned, fixed binary (35)); dcl message_segment_$open entry (character (*), character (*), fixed binary, fixed binary (35)); dcl message_segment_$read_message_index entry (fixed binary, pointer, pointer, fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl request_id_ entry (fixed binary (71)) returns (character (19)); dcl cleanup condition; dcl (addr, after, before, convert, index, length, max, null, rtrim, substr, sum, unspec, verify) builtin; /* */ call cu_$arg_count (n_arguments, code); if code ^= 0 then do; call com_err_ (code, LIST_IMFT_REQUESTS); return; end; the_argument_list = cu_$arg_list_ptr (); /* Establish defaults */ array_bound = max (n_arguments, 1); /* PL/I abhors a vacuum */ n_selections = 0; /* no path, entry, or ID selections */ request_type = imft_default_rqt_ (); /* returns real name of default request type */ queue = -1; /* list all queues by default */ output_mode = BRIEF; /* default is -brief */ path_output_mode = DEFAULT; /* default is -absp if -long and -etnm if -brief */ id_output_mode = DEFAULT; /* default is -short_id if -brief and -long_id if -long */ position_mode = DEFAULT; /* default is -no_position */ user_selection = USER; /* default is -own */ MAIN_LIR_BLOCK: begin; dcl selection_types (array_bound) fixed binary (2); /* type of selection indicated by this argument */ dcl dir_uids (array_bound) bit (36) aligned; /* UIDs of directory part of pathname selections */ selection_types (*) = NONE; dir_uids (*) = ""b; id_qualifier_idx = 0; /* index of first -id STR */ /* Scan the argument list, verify the syntax of all request_identifiers, process all control arguments, and apply other appropriate defaults */ do argument_idx = 1 to n_arguments; call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, the_argument_list); if code ^= 0 then do; call com_err_ (code, LIST_IMFT_REQUESTS, "Accessing argument #^d.", argument_idx); return; end; if index (argument, "-") = 1 then /* a control argument */ if (argument = "-destination") | (argument = "-ds") then do; remote = "0"b; go to FOREIGN_SYSTEM; end; else if (argument = "-source") | (argument = "-sc") then do; remote = "1"b; FOREIGN_SYSTEM: call get_next_argument ("A system name", foreign_system); if remote then request_type = substr ("From_" || foreign_system, 1, length (request_type)); else request_type = substr ("To_" || foreign_system, 1, length (request_type)); call iod_info_$generic_type (request_type, generic_type, code); if code ^= 0 then do; /* couldn't lookup the specified destination */ INVALID_DESTINATION_SPECIFICATION: if code = error_table_$id_not_found then call com_err_ (0, LIST_IMFT_REQUESTS, "Unknown ^[source^;destination^]. ""^a""", remote, foreign_system); else call com_err_ (code, LIST_IMFT_REQUESTS, "-^[source^;destination^] ""^a""", remote, foreign_system); return; end; if generic_type ^= FT_GENERIC_TYPE then do; call com_err_ (0, LIST_IMFT_REQUESTS, "Unknown ^[source^;destination^]. ""^a""", remote, foreign_system); return; end; end; else if (argument = "-queue") | (argument = "-q") then do; call get_next_argument ("A number", queue_string); queue = cv_dec_check_ (queue_string, code); if code ^= 0 then do; INVALID_QUEUE_SPECIFICATION: call com_err_ (0, LIST_IMFT_REQUESTS, "The queue must be a number between 1 and 4; not ""^a"".", queue_string); return; end; if (queue < 1) | (queue > 4) then go to INVALID_QUEUE_SPECIFICATION; end; /* will check if queue is OK for destination later */ else if (argument = "-all") | (argument = "-a") then queue = -1; /* special indicator to match all queues */ else if (argument = "-brief") | (argument = "-bf") then output_mode = BRIEF; else if (argument = "-long") | (argument = "-lg") then output_mode = LONG; else if (argument = "-totals") | (argument = "-total") | (argument = "-tt") then output_mode = TOTALS; else if (argument = "-absolute_pathname") | (argument = "-absp") then path_output_mode = LONG; else if (argument = "-entryname") | (argument = "-etnm") then path_output_mode = BRIEF; else if (argument = "-long_id") | (argument = "-lgid") then id_output_mode = LONG; else if (argument = "-short_id") | (argument = "-shid") then id_output_mode = BRIEF; else if (argument = "-position") | (argument = "-psn") then position_mode = SHOW_POSITION; else if (argument = "-no_position") | (argument = "-npsn") then position_mode = NO_POSITION; else if argument = "-own" then user_selection = USER; else if (argument = "-admin") | (argument = "-am") then user_selection = ALL; else if argument = "-user" then do; call get_next_argument ("A user ID", user_id); if after (after (user_id, "."), ".") ^= "" then do; call com_err_ (0, LIST_IMFT_REQUESTS, "Improper syntax for user ID. ""^a""", user_id); return; end; match_any_person = (before (user_id, ".") = "") | (before (user_id, ".") = "*"); match_any_project = (after (user_id, ".") = "") | (after (user_id, ".") = "*"); if match_any_person & match_any_project then user_selection = ALL; else do; /* matches a subset of all users */ user_selection = SUBSET; person_id = before (user_id, "."); project_id = after (user_id, "."); if person_id = "" then person_id = "*"; if project_id = "" then project_id = "*"; end; end; else if (argument = "-entry") | (argument = "-et") then do; call get_next_argument ("A starname", an_ename); call check_star_name_$entry (an_ename, code); if (code ^= 0) & (code ^= 1) & (code ^= 2) then do; call com_err_ (code, LIST_IMFT_REQUESTS, "^a", an_ename); return; end; n_selections.entry = n_selections.entry + 1; selection_types (argument_idx) = ENTRY; end; else if argument = "-id" then do; call get_next_argument ("A request ID match string", request_id_nonvarying); request_id = rtrim (request_id_nonvarying); if verify (request_id, "0123456789.") ^= 0 then do; INVALID_REQUEST_ID: call com_err_ (0, LIST_IMFT_REQUESTS, "Improper syntax for a request ID match string. ""^a""", request_id); return; end; if after (after (request_id, "."), ".") ^= "" then go to INVALID_REQUEST_ID; if length (before (request_id, ".")) > length ("YYMMDDHHMMSS") then go to INVALID_REQUEST_ID; if length (after (request_id, ".")) > length ("FFFFFF") then go to INVALID_REQUEST_ID; n_selections.id = n_selections.id + 1; selection_types (argument_idx) = ID; if id_qualifier_idx = 0 then id_qualifier_idx = argument_idx; end; /* record index of first -id STR */ else do; call com_err_ (error_table_$badopt, LIST_IMFT_REQUESTS, """^a""", argument); return; end; else do; /* a pathname selection */ call expand_pathname_ (argument, a_dirname, an_ename, code); if code ^= 0 then do; call com_err_ (code, LIST_IMFT_REQUESTS, "^a", argument); return; end; call check_star_name_$entry (an_ename, code); if (code ^= 0) & (code ^= 1) & (code ^= 3) then do; call com_err_ (code, LIST_IMFT_REQUESTS, pathname_ (a_dirname, an_ename)); return; end; n_selections.path = n_selections.path + 1; selection_types (argument_idx) = PATH; call hcs_$status_long (a_dirname, "", CHASE, addr (local_sb), null (), code); if (code = 0) | (code = error_table_$no_s_permission) then dir_uids (argument_idx) = local_sb.uid; end; /* get the UID now: will need it later */ end; if (output_mode = TOTALS) & ((path_output_mode ^= DEFAULT) | (id_output_mode ^= DEFAULT) | (position_mode ^= DEFAULT)) then do; if path_output_mode ^= DEFAULT then call com_err_ (error_table_$inconsistent, LIST_IMFT_REQUESTS, """-total"" and ""^[-entryname^;absolute_pathname^]""", (path_output_mode = BRIEF)); if id_output_mode ^= DEFAULT then call com_err_ (error_table_$inconsistent, LIST_IMFT_REQUESTS, """-total"" and ""^[-short_id^;long_id^]""", (id_output_mode = BRIEF)); if position_mode ^= DEFAULT then call com_err_ (error_table_$inconsistent, LIST_IMFT_REQUESTS, """-total"" and ""^[-no_position^;-position^]""", (position_mode = NO_POSITION)); return; end; if path_output_mode = DEFAULT then path_output_mode = output_mode; if id_output_mode = DEFAULT then id_output_mode = output_mode; if position_mode = DEFAULT then position_mode = NO_POSITION; if ((n_selections.entry + n_selections.path) > 0) & (n_selections.id > 1) then do; call com_err_ (error_table_$inconsistent, LIST_IMFT_REQUESTS, "More than one ""-id"" control argument with path/entry selections."); return; end; call iod_info_$queue_data (request_type, default_queue, max_queues, code); if code ^= 0 then go to INVALID_DESTINATION_SPECIFICATION; if queue = 0 then queue = default_queue; /* supply default if needed */ if queue > max_queues then do; call com_err_ (0, LIST_IMFT_REQUESTS, "^[Source^;Destination^] ^a has only ^d queue^[s^]; you specified queue ^d.", remote, request_type, max_queues, (max_queues ^= 1), queue); return; end; /* */ /* Fetch the next argument */ get_next_argument: procedure (p_arg_description, p_argument); dcl p_arg_description character (*) parameter; dcl p_argument character (*) parameter; dcl control_argument character (32); control_argument = argument; /* save control arg's name for error messages */ if argument_idx = n_arguments then do; /* there is no next argument */ call com_err_ (error_table_$noarg, LIST_IMFT_REQUESTS, "^a must follow ""^a"".", p_arg_description, control_argument); go to ABORT_ARGUMENT_PARSE; end; argument_idx = argument_idx + 1; call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, code, the_argument_list); if code ^= 0 then do; call com_err_ (code, LIST_IMFT_REQUESTS, "Accessing argument #^d.", argument_idx); go to ABORT_ARGUMENT_PARSE; end; if argument_lth > length (p_argument) then do; /* it's too long */ call com_err_ (0, LIST_IMFT_REQUESTS, "Value after ""^a"" may not be longer than ^d characters. ""^a""", control_argument, length (p_argument), argument); go to ABORT_ARGUMENT_PARSE; end; p_argument = argument; /* it's OK */ return; end get_next_argument; /* */ /* Argument parsing completed: open the appropriate queues and determine if the user has sufficient access */ system_area_ptr = get_system_free_area_ (); queue_indeces (*) = 0; /* for cleanup handler */ message_ids_ptr, ft_request_ptr = null (); unspec (local_mmi) = ""b; local_mmi.version = MSEG_MESSAGE_INFO_V1; on condition (cleanup) call cleanup_handler (); if (position_mode = SHOW_POSITION) & (user_selection = USER) then do; person_id = before (get_group_id_ (), "."); project_id = "*"; /* need to match just this user */ end; if (position_mode = SHOW_POSITION) | (user_selection ^= USER) then access_required = R_EXTENDED_ACCESS; else do; access_required = O_EXTENDED_ACCESS; local_mmi.own = "1"b; end; total_requests (*) = -1; /* don't know what's in any of the queues yet */ if queue = -1 then do; /* want to examine all the queues */ opened_a_queue = "0"b; do queue_idx = 1 to max_queues; call open_single_queue (queue_idx); if queue_indeces (queue_idx) ^= 0 then opened_a_queue = "1"b; end; if ^opened_a_queue then go to RETURN_FROM_LIST_IMFT_REQUESTS; end; else do; /* just one queue please */ call open_single_queue (queue); if queue_indeces (queue) = 0 then go to RETURN_FROM_LIST_IMFT_REQUESTS; end; /* couldn't open it: nothing we can do */ /* */ /* Opens a single queue's message segment and validates access */ open_single_queue: procedure (p_queue_number); dcl p_queue_number fixed binary parameter; dcl queue_ename character (32); dcl queue_picture picture "9"; dcl queue_mode bit (36) aligned; queue_ename = rtrim (request_type) || "_" || convert (queue_picture, p_queue_number) || ".ms"; call message_segment_$open (imft_data_$queue_dirname, queue_ename, queue_indeces (p_queue_number), code); if code ^= 0 then do; call com_err_ (code, LIST_IMFT_REQUESTS, "Opening ^a.", pathname_ (imft_data_$queue_dirname, queue_ename)); go to RETURN_FROM_LIST_IMFT_REQUESTS; end; call message_segment_$get_mode_index (queue_indeces (p_queue_number), queue_mode, code); if code ^= 0 then do; call com_err_ (code, LIST_IMFT_REQUESTS, "Determining access to ^a.", pathname_ (imft_data_$queue_dirname, queue_ename)); go to RETURN_FROM_LIST_IMFT_REQUESTS; end; if (queue_mode & access_required) ^= access_required then do; call com_err_ (error_table_$moderr, LIST_IMFT_REQUESTS, "You do not have ""^[r^;o^]"" access to ^a queue ^d.", (access_required = R_EXTENDED_ACCESS), request_type, p_queue_number); call message_segment_$close (queue_indeces (p_queue_number), (0)); queue_indeces (p_queue_number) = 0; /* not fatal: just don't list this queue */ return; end; if (queue_mode & S_EXTENDED_ACCESS) = S_EXTENDED_ACCESS then do; call message_segment_$get_message_count_index (queue_indeces (p_queue_number), total_requests (p_queue_number), code); if code ^= 0 then /* couldn't get the message count: not fatal */ call com_err_ (code, LIST_IMFT_REQUESTS, "Determining number of messages in ^a.", pathname_ (imft_data_$queue_dirname, queue_ename)); end; return; end open_single_queue; /* */ /* Scan each of the selected queues generating a list of matching requests */ first_id_indeces (*) = 0; /* index into message_ids array of first request in queue */ selected_requests (*) = 0; call get_temp_segment_ (LIST_IMFT_REQUESTS, message_ids_ptr, code); if code ^= 0 then do; call com_err_ (code, LIST_IMFT_REQUESTS, "Getting a temporary segment."); go to RETURN_FROM_LIST_IMFT_REQUESTS; end; total_message_ids = 0; /* haven't used any yet */ process_selections = ((n_selections.path + n_selections.entry + n_selections.id) ^= 0); if ((n_selections.path + n_selections.entry) > 0) & (n_selections.id = 1) then call cu_$arg_ptr_rel (id_qualifier_idx, id_qualifier_ptr, id_qualifier_lth, (0), the_argument_list); else do; /* no -id STR qualifier present: avoid faults */ id_qualifier_ptr = addr (LIST_IMFT_REQUESTS); id_qualifier_lth = 0; end; do queue_idx = 1 to max_queues; /* scan each queue that's open */ if queue_indeces (queue_idx) ^= 0 then call scan_single_queue (queue_idx); end; if sum (selected_requests (*)) = 0 then do; /* no matching requests were found */ all_queues_empty = "1"b; /* ... assume thery're all empty */ do queue_idx = 1 to max_queues while (all_queues_empty); if total_requests (queue_idx) ^= 0 then all_queues_empty = "0"b; end; if all_queues_empty then /* ... and there's nothing in any of the queues */ call ioa_ ("There are no requests in any ^a queue.", request_type); else do; /* ... explain about each empty queue */ do queue_idx = 1 to max_queues; if queue_indeces (queue_idx) ^= 0 then call ioa_ ("^/^a queue ^d:^-^[0 requests^]^[; ^]^[^d total request^[s^]^].", request_type, queue_idx, (total_requests (queue_idx) ^= 0), (total_requests (queue_idx) > 0), (total_requests (queue_idx) ^= -1), total_requests (queue_idx), (total_requests (queue_idx) ^= 1)); end; call ioa_ (""); end; go to RETURN_FROM_LIST_IMFT_REQUESTS; end; /* */ /* Scans a single queue and records the indeces of all requests matching the selection criteria */ scan_single_queue: procedure (p_queue_number); dcl p_queue_number fixed binary parameter; dcl user_id character (30); dcl position fixed binary; dcl previous_message_id bit (72) aligned; dcl request_uid bit (36) aligned; dcl (retry_read, matches) bit (1) aligned; position = 0; retry_read = "0"b; /* this isn't a retry */ RETRY_FIRST_READ: local_mmi.message_code = MSEG_READ_FIRST; call message_segment_$read_message_index (queue_indeces (p_queue_number), system_area_ptr, addr (local_mmi), code); if ^retry_read then if code = error_table_$bad_segment then do; retry_read = "1"b; /* queue might have been salvaged: try again */ go to RETRY_FIRST_READ; end; do while (code = 0); /* while we've got a message */ previous_message_id = local_mmi.ms_id; /* needed to read the next message */ position = position + 1; /* count the messages as we read them */ ft_request_ptr = local_mmi.ms_ptr; user_id = substr (local_mmi.sender_id, 1, (length (rtrim (local_mmi.sender_id)) - 2)); if (ft_request.hdr_version ^= queue_msg_hdr_version_1) | (ft_request.version ^= FT_REQUEST_VERSION_1) then do; /* unrecognized message format */ if (user_selection ^= USER) | (position_mode = SHOW_POSITION) then do; if user_selection ^= ALL then do; /* ... check if it's from an interesting user */ if person_id ^= "*" then if before (user_id, ".") ^= person_id then go to SKIP_THIS_MESSAGE; if project_id ^= "*" then if after (user_id, ".") ^= project_id then go to SKIP_THIS_MESSAGE; end; end; call add_this_message (); /* it's the right user anyway */ go to SKIP_THIS_MESSAGE; end; if (user_selection ^= USER) | (position_mode = SHOW_POSITION) then do; if user_selection ^= ALL then do; /* must check if the user IDs match */ if person_id ^= "*" then if before (user_id, ".") ^= person_id then go to SKIP_THIS_MESSAGE; if project_id ^= "*" then if after (user_id, ".") ^= project_id then go to SKIP_THIS_MESSAGE; end; end; if process_selections then do; /* have to match path/entry/request ID */ matches = "0"b; /* until proven otherwise */ do argument_idx = 1 to n_arguments while (^matches); if selection_types (argument_idx) ^= NONE then do; call cu_$arg_ptr_rel (argument_idx, argument_ptr, argument_lth, (0), the_argument_list); if (selection_types (argument_idx) = PATH) | (selection_types (argument_idx) = ENTRY) then do; if selection_types (argument_idx) = PATH then call expand_pathname_ (argument, a_dirname, an_ename, (0)); else an_ename = argument; call match_star_name_ ((ft_request.ename), an_ename, code); if code = 0 then /* entry names match ... */ if selection_types (argument_idx) = PATH then do; call hcs_$status_long ((ft_request.dirname), "", CHASE, addr (local_sb), null (), code); if (code = 0) | (code = error_table_$no_s_permission) then request_uid = local_sb.uid; else request_uid = ""b; if (request_uid ^= ""b) & (dir_uids (argument_idx) ^= ""b) then matches = (request_uid = dir_uids (argument_idx)); else if (request_uid = ""b) & (dir_uids (argument_idx) = ""b) then matches = (ft_request.dirname = a_dirname); end; else matches = "1"b; if matches & (id_qualifier ^= "") then matches = match_request_id_ (ft_request.msg_time, id_qualifier); end; else do; /* a request ID: only if not using ID as a qualifier */ if id_qualifier = "" then matches = match_request_id_ (ft_request.msg_time, argument); end; end; end; if ^matches then go to SKIP_THIS_MESSAGE; end; call add_this_message (); /* it passes all the selection criteria */ SKIP_THIS_MESSAGE: free ft_request in (system_area); /* done with this request for now */ ft_request_ptr = null (); retry_read = "0"b; /* first attempt to read the next message */ RETRY_READ_NEXT_MESSAGE: local_mmi.message_code = MSEG_READ_AFTER_SPECIFIED; local_mmi.ms_id = previous_message_id; call message_segment_$read_message_index (queue_indeces (p_queue_number), system_area_ptr, addr (local_mmi), code); if ^retry_read then if code = error_table_$bad_segment then do; retry_read = "1"b; /* message segment may have been salvaged */ go to RETRY_READ_NEXT_MESSAGE; end; end; if (code ^= 0) & (code ^= error_table_$no_message) then do; call com_err_ (code, LIST_IMFT_REQUESTS, "Reading from ^a queue ^d.", request_type, p_queue_number); call message_segment_$close (queue_indeces (p_queue_number), (0)); queue_indeces (p_queue_number) = 0; /* fatal error while reading: drop this queue */ end; return; /* Internal to scan_single_queue: adds the current request to the list of selected requests */ add_this_message: procedure (); selected_requests (p_queue_number) = selected_requests (p_queue_number) + 1; total_message_ids = total_message_ids + 1; message_ids.id (total_message_ids) = local_mmi.ms_id; message_ids.position (total_message_ids) = position; if first_id_indeces (p_queue_number) = 0 then first_id_indeces (p_queue_number) = total_message_ids; return; end add_this_message; end scan_single_queue; /* */ /* Display the descriptions of each matching request */ do queue_idx = 1 to max_queues; if queue_indeces (queue_idx) ^= 0 then do; if (selected_requests (queue_idx) ^= 0) | (total_requests (queue_idx) > 0) then call ioa_ ("^/^a queue ^d:^-^d request^[s^]^[; ^d total request^[s^]^].", request_type, queue_idx, selected_requests (queue_idx), (selected_requests (queue_idx) ^= 1), (total_requests (queue_idx) ^= -1), total_requests (queue_idx), (total_requests (queue_idx) ^= 1)); if output_mode ^= TOTALS then do; /* some requests to display */ first_message_in_queue = "1"b; do message_idx = first_id_indeces (queue_idx) to (first_id_indeces (queue_idx) + selected_requests (queue_idx) - 1); call display_single_request (queue_idx, message_ids.id (message_idx), message_ids.position (message_idx)); end; end; end; end; if (output_mode ^= LONG) | first_message_in_queue then call ioa_ (""); /* */ /* Displays a single request's description */ display_single_request: procedure (p_queue, p_message_id, p_position); dcl (p_queue, p_position) fixed binary parameter; dcl p_message_id bit (72) aligned parameter; dcl user_id character (30); dcl time_queued_string character (24); dcl long_id_string character (19); dcl short_id_string character (8); dcl (retry_read, supported_version) bit (1) aligned; retry_read = "0"b; READ_THE_MESSAGE: local_mmi.message_code = MSEG_READ_SPECIFIED; local_mmi.ms_id = p_message_id; call message_segment_$read_message_index (queue_indeces (p_queue), system_area_ptr, addr (local_mmi), code); if retry_read then if code = error_table_$bad_segment then do; retry_read = "1"b; /* message segment has been salvaged */ go to READ_THE_MESSAGE; end; if code ^= 0 then do; /* couldn't get the message: OK if it was deleted */ if code ^= error_table_$no_message then call com_err_ (code, LIST_IMFT_REQUESTS, "Attempting to read message ^24.3b from ^a queue ^d.", p_message_id, request_type, p_queue); return; end; ft_request_ptr = local_mmi.ms_ptr; user_id = substr (local_mmi.sender_id, 1, (length (rtrim (local_mmi.sender_id)) - 2)); if (ft_request.hdr_version ^= queue_msg_hdr_version_1) | (ft_request.version ^= FT_REQUEST_VERSION_1) then do; supported_version = "0"b; /* unknown message */ unspec (ft_request.msg_time) = local_mmi.ms_id; call date_time_ (ft_request.msg_time, time_queued_string); end; else do; supported_version = "1"b; /* we recognize this message */ if (ft_request.state < STATE_UNPROCESSED) | (ft_request.state > STATE_RUNNING) then ft_request.state = STATE_UNKNOWN; /* ... but the state is garbage so "fix" it */ long_id_string = request_id_ (ft_request.msg_time); short_id_string = substr (long_id_string, 7, 8); call date_time_ (ft_request.msg_time, time_queued_string); end; if first_message_in_queue then do; first_message_in_queue = "0"b; call ioa_ (""); /* put some space after the totals line */ if (user_selection ^= USER) & (output_mode = BRIEF) then call ioa_ ("User^31t^[^7x^]^2xID^[^19x^;^8x^]^[Entry name^;Pathname^]", (position_mode = SHOW_POSITION), (id_output_mode = LONG), (path_output_mode = BRIEF)); end; if output_mode = BRIEF then if supported_version then call ioa_ ("^[^30a^;^s^]^[^6d)^;^s^]^2x^[^a^s^;^s^a^]^2x^[^a^s^;^s^a^]^[ (^a)^]", (user_selection ^= USER), user_id, (position_mode = SHOW_POSITION), p_position, (id_output_mode = BRIEF), short_id_string, long_id_string, (path_output_mode = BRIEF), ft_request.ename, pathname_ ((ft_request.dirname), (ft_request.ename)), (ft_request.state ^= STATE_UNPROCESSED), STATE_NAMES (ft_request.state)); else call ioa_ ("^[^30a^;^s^] (unrecognized request format); time queued: ^a", (user_selection ^= USER), user_id, time_queued_string); else do; /* long output format */ if supported_version then do; if user_selection ^= USER then call ioa_ ("User:^21t^a", user_id); if position_mode = SHOW_POSITION then call ioa_ ("Position in queue:^21t^d", p_position); call ioa_ ("Request ID:^21t^[^a^;^s^a^]", (id_output_mode = BRIEF), short_id_string, long_id_string); call ioa_ ("Time queued:^21t^a", time_queued_string); call ioa_ ("^[Local ^[entry^;pathname^]^;^[Entry^;Pathname^]^]:^21t^[^a^;^s^a^]", ft_request.foreign_path_given, (path_output_mode = BRIEF), (path_output_mode = BRIEF), ft_request.ename, pathname_ ((ft_request.dirname), (ft_request.ename))); call ioa_ ("State:^21t^a", STATE_NAMES (ft_request.state)); if ft_request.foreign_path_given then call ioa_ ("Foreign pathname:^21t^a", pathname_ (ft_request.foreign_dirname, ft_request.foreign_ename)); if ft_request.foreign_user_given then call ioa_ ("Foreign user:^21t^a", ft_request.foreign_user); if (ft_request.directory_creation_mode ^= "00"b) then call ioa_ ("Options:^21t^[replace_directories^;merge_directories^]", (ft_request.directory_creation_mode = REPLACE_DIRECTORIES)); if ft_request.delete then call ioa_ ("Delete:^21tyes"); if ft_request.extend then call ioa_ ("Extend:^21tyes"); if ft_request.notify then call ioa_ ("Notify:^21tyes"); if ft_request.update then call ioa_ ("Update:^21tyes"); end; else do; /* unrecognized message format */ call ioa_ ("User:^21t^a", user_id); call ioa_ ("Time queued:^21t^a", time_queued_string); call ioa_ ("^5x(unrecognized request format)"); end; call ioa_ (""); /* and end it with a blank line */ end; free ft_request in (system_area); ft_request_ptr = null (); return; end display_single_request; end MAIN_LIR_BLOCK; /* */ RETURN_FROM_LIST_IMFT_REQUESTS: call cleanup_handler (); ABORT_ARGUMENT_PARSE: return; /* Cleanup after an invocation of list_imft_requests */ cleanup_handler: procedure (); if ft_request_ptr ^= null () then do; free ft_request in (system_area); ft_request_ptr = null (); end; if message_ids_ptr ^= null () then do; call release_temp_segment_ (LIST_IMFT_REQUESTS, message_ids_ptr, (0)); message_ids_ptr = null (); end; do queue_idx = 1 to max_queues; if queue_indeces (queue_idx) ^= 0 then do; call message_segment_$close (queue_indeces (queue_idx), (0)); queue_indeces (queue_idx) = 0; end; end; return; end cleanup_handler; /* */ %include "_imft_ft_request"; %page; %include mseg_message_info; %page; %include queue_msg_hdr; %page; %include status_structures; end list_imft_requests;  old_imft_io_.pl1 10/14/88 1248.7r w 10/14/88 1214.6 447327 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* I/O module to transmit files between Multics sites using I/O daemon record oriented communications modules */ /* Created: October 1980 by G. Palter */ /* Modified: April 1982 by G. Palter to greatly simplify attach description and internal operation */ /* Modified: 26 July 1982 by G. Palter to add get_channel_names control order */ /* Modified: February 1983 by Robert Coren to change from imft_io_ to old_imft_io_ */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ old_imft_io_: procedure (); return; /* not an entry */ /* Parameters */ dcl P_iocb_ptr pointer parameter; /* *: -> I/O switch being operated upon */ dcl P_code fixed binary (35) parameter; dcl P_attach_options (*) character (*) varying parameter; /* attach: attachment arguments */ dcl P_loud_sw bit (1) parameter; /* attach: ON => attachment errors should call com_err_ */ dcl P_open_mode fixed binary parameter; /* open: opening mode */ dcl P_open_sw bit (1) parameter; /* open: obsolete parameter */ dcl P_data_lth fixed binary (21) parameter; /* get_*: set to # of characters read into buffer; put_chars: # of characters to transmit as logical record */ dcl P_buffer_ptr pointer parameter; /* get_*: -> area to place result of read */ dcl P_buffer_max_lth fixed binary (21) parameter; /* get_*: size of area in characters */ dcl P_data_ptr pointer parameter; /* put_chars: -> data stream to be written */ dcl P_order character (*) parameter; /* control: name of control order to be performed */ dcl P_info_ptr pointer parameter; /* control: -> additional information required to execute the control order */ dcl P_new_modes character (*) parameter; /* modes: new modes to be set */ dcl P_old_modes character (*) parameter; /* modes: set to modes in effect before change */ /* Local copies of parameters */ dcl iocb_ptr pointer; dcl code fixed binary (35); dcl argument character (argument_lth) based (argument_ptr);/* based on attach options */ dcl argument_lth fixed binary (21); dcl argument_ptr pointer; dcl loud_sw bit (1) aligned; dcl open_mode fixed binary; dcl buffer_lth fixed binary (21); dcl order character (32); dcl info_ptr pointer; /* Remaining declarations */ dcl 1 local_tgci aligned like tty_get_channel_info; /* for get_channel_names */ dcl system_area area aligned based (system_area_ptr); dcl system_area_ptr pointer; dcl argument_idx fixed binary; /* # of attach option being processed */ dcl direction character (32); dcl (input_description_idx, output_description_idx) fixed binary; dcl an_attach_description character (512); dcl terminal_switch_name character (32); dcl terminal_iocb_ptr pointer; dcl terminal_attach_count fixed binary static initial (0); dcl terminal_attach_count_pic picture "999"; dcl ips_mask bit (36); dcl local_record_type fixed binary; dcl IMFT_IO_ character (32) static options (constant) initial ("old_imft_io_"); dcl N_BITS_PER_CHARACTER fixed binary static options (constant) initial (9); dcl RELATIVE_SECONDS bit (2) static options (constant) initial ("11"b); dcl ONE_MINUTE fixed binary (71) static options (constant) initial (60); dcl SP character (1) static options (constant) initial (" "); /* format: off */ dcl (error_table_$action_not_performed, error_table_$badopt, error_table_$bad_arg, error_table_$bad_conversion, error_table_$bad_mode, error_table_$eof_record, error_table_$improper_data_format, error_table_$invalid_read, error_table_$invalid_write, error_table_$noarg, error_table_$no_operation, error_table_$not_attached, error_table_$not_closed, error_table_$not_detached, error_table_$not_open, error_table_$null_info_ptr, error_table_$short_record, error_table_$undefined_order_request, error_table_$unimplemented_version) fixed binary (35) external; dcl (imft_et_$cant_get_channel_names, imft_et_$reply_pending, imft_et_$timeout) fixed binary (35) external; /* format: on */ dcl add_bit_offset_ entry (pointer, fixed binary (24)) returns (pointer); dcl com_err_ entry () options (variable); dcl continue_to_signal_ entry (fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$reset_ips_mask entry (bit (36), bit (36)); dcl hcs_$set_ips_mask entry (bit (36), bit (36)); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1)); dcl iox_$attach_ioname entry (character (*), pointer, character (*), fixed binary (35)); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl iox_$close entry (pointer, fixed binary (35)); dcl iox_$destroy_iocb entry (pointer, fixed binary (35)); dcl iox_$detach_iocb entry (pointer, fixed binary (35)); dcl iox_$err_no_operation entry () options (variable); dcl iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35)); dcl iox_$propagate entry (pointer); dcl iox_$read_record entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl iox_$write_record entry (pointer, pointer, fixed binary (21), fixed binary (35)); dcl requote_string_ entry (character (*)) returns (character (*)); dcl timer_manager_$alarm_call entry (fixed binary (71), bit (2), entry); dcl timer_manager_$reset_alarm_call entry (entry); dcl (any_other, cleanup, imft_debug_, imft_read_abort_, imft_write_abort_) condition; dcl (addr, collate, convert, currentsize, divide, hbound, lbound, length, ltrim, min, mod, null, rtrim, string, substr, verify, unspec) builtin; /* */ /* Description of a switch attached through this module */ dcl 1 iad aligned based (iad_ptr), 2 attach_description character (1024) varying, /* attach description for this I/O switch */ 2 open_description character (24) varying, /* open description for this I/O switch */ 2 input_switch like switch_info, /* defines the input terminal switch */ 2 output_switch like switch_info, /* defines the output terminal switch */ 2 abort_code fixed binary (35), /* status code of last aborted I/O operation */ 2 flags aligned, 3 input_direction bit (1) unaligned, /* ON => receives data from remote system */ 3 abort_in_progress bit (1) unaligned, /* ON => last I/O operation failed */ 3 debug_mode bit (1) unaligned, /* ON => trying to debug IMFT: stop on errors */ 3 pad bit (33) unaligned; dcl iad_ptr pointer; /* Description of a single terminal level I/O switch */ dcl 1 switch_info aligned based (switch_info_ptr), 2 terminal_iocb_ptr pointer, /* -> IOCB for terminal level module */ 2 current_physical_record_type fixed binary, /* type of record currently in buffer (if any) */ 2 current_physical_record_n_els fixed binary (24), /* # of characters or bits in current record */ 2 current_physical_record_used fixed binary (24), /* # of characters or bits already returned to caller */ 2 pad bit (36), 2 tior, /* terminal_io_record used for I/O */ 3 header like terminal_io_record.header, 3 data character (IMFT_PHYSICAL_RECORD_LTH) unaligned; dcl switch_info_ptr pointer; /* */ /* Physical record structure used to transmit data and control information */ dcl 1 imft_physical_record aligned based (ipr_ptr), 2 pad1 bit (2) unaligned, 2 record_type fixed binary (7) unaligned unsigned, /* type of record: data or control */ 2 pad2 bit (2) unaligned, 2 flags unaligned, 3 binary bit (1) unaligned, /* ON => binary data in record as 7-bit bytes */ 3 bolr bit (1) unaligned, /* ON => this is first physical record of a logical record */ 3 eolr bit (1) unaligned, /* ON => last physical record in logical record */ 3 pad3 bit (4) unaligned, 2 n_els unaligned, /* # of elements (characters or 7-bit bytes) */ 3 pad4 bit (2) unaligned, 3 high_order bit (7) unaligned, 3 pad5 bit (2) unaligned, 3 low_order bit (7) unaligned, 2 data character (IMFT_PHYSICAL_RECORD_DATA_LTH) unaligned; /* the actual data */ dcl 1 ipr_data_overlay unaligned based (addr (imft_physical_record.data)), 2 elements (IMFT_PHYSICAL_RECORD_DATA_LTH) unaligned,/* 7-bit bytes of binary data unpacked in 9 bits */ 3 pad1 bit (2) unaligned, 3 byte bit (7) unaligned; dcl ipr_ptr pointer; dcl ( IMFT_PHYSICAL_RECORD_LTH initial (80), /* size of each physical record */ IMFT_PHYSICAL_RECORD_DATA_LTH initial (76), /* # of bytes of user's data in each record */ IMFT_PHYSICAL_RECORD_DATA_BITS_LTH initial (532) /* # of bits of user's data in each record for binary data */ ) fixed binary static options (constant); /* */ /* Attach an I/O switch for file transfer */ old_imft_io_attach: entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code); iocb_ptr = P_iocb_ptr; loud_sw = P_loud_sw; code = 0; iad_ptr = null (); /* avoid freeing garbage if I/O switch already attached */ if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do; P_code = error_table_$not_detached; if loud_sw then call com_err_ (P_code, IMFT_IO_, "For switch ^a.", iocb_ptr -> iocb.name); return; end; system_area_ptr = get_system_free_area_ (); on condition (cleanup) call cleanup_attachment ((0)); /* Process attachment options */ if hbound (P_attach_options, 1) < 1 then call abort_attachment (error_table_$noarg, """-direction"", ""-input_description"", and ""-output_description"" must be supplied."); allocate iad in (system_area) set (iad_ptr); iad.input_switch.terminal_iocb_ptr, /* keeps cleanup handler happy */ iad.output_switch.terminal_iocb_ptr = null (); direction = ""; /* haven't seen -direction yet */ input_description_idx = 0; /* haven't seen -input_description yet */ output_description_idx = 0; /* haven't seen -output_description yet */ iad.debug_mode = "0"b; /* haven't seen -debug yet */ iad.attach_description = ""; iad.open_description = ""; do argument_idx = lbound (P_attach_options, 1) to hbound (P_attach_options, 1); argument_ptr = substraddr (P_attach_options (argument_idx), 1); argument_lth = length (P_attach_options (argument_idx)); if argument = "-direction" then do; direction = get_string_argument (); if (direction ^= "input") & (direction ^= "output") then call abort_attachment (error_table_$bad_arg, "-direction must be followed by ""input"" or ""output""; not ""^a"".", direction); end; else if (argument = "-input_description") | (argument = "-ids") then do; an_attach_description = get_string_argument (); input_description_idx = argument_idx; end; else if (argument = "-output_description") | (argument = "-ods") then do; an_attach_description = get_string_argument (); output_description_idx = argument_idx; end; else if argument = "-debug" then iad.debug_mode = "1"b; else call abort_attachment (error_table_$badopt, """^a""", argument); end; if direction = "" then call abort_attachment (error_table_$noarg, "-direction"); if input_description_idx = 0 then call abort_attachment (error_table_$noarg, "-input_description"); if output_description_idx = 0 then call abort_attachment (error_table_$noarg, "-output_description"); /* Construct our attach description */ iad.attach_description = rtrim (IMFT_IO_); iad.attach_description = iad.attach_description || " -direction "; iad.attach_description = iad.attach_description || rtrim (direction); argument_ptr = substraddr (P_attach_options (input_description_idx), 1); argument_lth = length (P_attach_options (input_description_idx)); iad.attach_description = iad.attach_description || " -input_description "; iad.attach_description = iad.attach_description || requote_string_ (argument); argument_ptr = substraddr (P_attach_options (output_description_idx), 1); argument_lth = length (P_attach_options (output_description_idx)); iad.attach_description = iad.attach_description || " -output_description "; iad.attach_description = iad.attach_description || requote_string_ (argument); /* Attach through the terminal level */ iad.input_direction = (direction = "input"); terminal_attach_count = terminal_attach_count + 1; if terminal_attach_count > 999 then terminal_attach_count = 1; terminal_switch_name = rtrim (IMFT_IO_) || ".input." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count)); call iox_$attach_ioname (terminal_switch_name, terminal_iocb_ptr, (P_attach_options (input_description_idx)), code); if code ^= 0 then call abort_attachment (code, "Unable to attach input channel via: ^a", P_attach_options (input_description_idx)); iad.input_switch.terminal_iocb_ptr = terminal_iocb_ptr; terminal_switch_name = rtrim (IMFT_IO_) || ".output." || ltrim (convert (terminal_attach_count_pic, terminal_attach_count)); call iox_$attach_ioname (terminal_switch_name, terminal_iocb_ptr, (P_attach_options (output_description_idx)), code); if code ^= 0 then call abort_attachment (code, "Unable to attach output channel via: ^a", P_attach_options (output_description_idx)); iad.output_switch.terminal_iocb_ptr = terminal_iocb_ptr; /* Initialize the input and output terminal switch structures */ iad.input_switch.current_physical_record_type, iad.output_switch.current_physical_record_type = -1; iad.input_switch.current_physical_record_n_els, iad.output_switch.current_physical_record_n_els = 0; iad.input_switch.current_physical_record_used, iad.output_switch.current_physical_record_used = 0; iad.input_switch.tior.version, iad.output_switch.tior.version = terminal_io_record_version_1; iad.input_switch.tior.device_type = READER_DEVICE; iad.output_switch.tior.device_type = PUNCH_DEVICE; iad.input_switch.tior.slew_type, iad.output_switch.tior.slew_type = SLEW_BY_COUNT; iad.input_switch.tior.slew_count, iad.output_switch.tior.slew_count = 1; string (iad.input_switch.tior.flags), string (iad.output_switch.tior.flags) = ""b; iad.input_switch.tior.element_size, iad.output_switch.tior.element_size = N_BITS_PER_CHARACTER; iad.input_switch.tior.n_elements, iad.output_switch.tior.n_elements = IMFT_PHYSICAL_RECORD_LTH; iad.abort_in_progress = "0"b; /* didn't encounter any errors yet */ iad.abort_code = 0; /* Mask and complete construction of the IOCB */ ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = addr (iad.attach_description); iocb_ptr -> iocb.attach_data_ptr = iad_ptr; iocb_ptr -> iocb.open = imft_io_open; iocb_ptr -> iocb.detach_iocb = imft_io_detach; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); RETURN_FROM_ATTACH: P_code = code; return; /* */ /* Open an I/O switch for file transfer */ imft_io_open: entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; open_mode = P_open_mode; if ^((iad.input_direction & (open_mode = Stream_input)) | (^iad.input_direction & (open_mode = Stream_output))) then do; /* opening mode and direction must agree */ P_code = error_table_$bad_mode; return; end; call iox_$open (iad.input_switch.terminal_iocb_ptr, Sequential_input, "0"b, P_code); if P_code ^= 0 then return; call iox_$open (iad.output_switch.terminal_iocb_ptr, Sequential_output, "0"b, P_code); if P_code ^= 0 then do; /* must close the other one to stay happy */ call iox_$close (iad.input_switch.terminal_iocb_ptr, (0)); return; end; iad.open_description = rtrim (iox_modes (open_mode)); ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); if iad.input_direction then iocb_ptr -> iocb.get_chars, iocb_ptr -> iocb.get_line = imft_io_get_chars; else iocb_ptr -> iocb.put_chars = imft_io_put_chars; iocb_ptr -> iocb.control = imft_io_control; iocb_ptr -> iocb.modes = imft_io_modes; iocb_ptr -> iocb.close = imft_io_close; iocb_ptr -> iocb.detach_iocb = imft_io_detach; iocb_ptr -> iocb.open_descrip_ptr = addr (iad.open_description); /* it's now open */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = 0; return; /* */ /* Close an I/O switch used for file transfer */ imft_io_close: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; code = 0; if iocb_ptr -> iocb.open_descrip_ptr = null () then do; P_code = error_table_$not_open; return; end; call iox_$close (iad.output_switch.terminal_iocb_ptr, code); if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0; call iox_$close (iad.input_switch.terminal_iocb_ptr, code); if (code = error_table_$not_open) | (code = error_table_$not_attached) then code = 0; ips_mask = ""b; on condition (cleanup) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.open_descrip_ptr = null (); iocb_ptr -> iocb.open = imft_io_open; iocb_ptr -> iocb.detach_iocb = imft_io_detach; iocb_ptr -> iocb.control, iocb_ptr -> iocb.modes, iocb_ptr -> iocb.get_chars, iocb_ptr -> iocb.get_line, iocb_ptr -> iocb.put_chars = iox_$err_no_operation; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = code; return; /* */ /* Detach an I/O switch from file transfer */ imft_io_detach: entry (P_iocb_ptr, P_code); iocb_ptr = P_iocb_ptr; code = 0; if iocb_ptr -> iocb.attach_descrip_ptr = null () then do; P_code = error_table_$not_attached; return; end; if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do; P_code = error_table_$not_closed; return; end; system_area_ptr = get_system_free_area_ (); iad_ptr = iocb_ptr -> iocb.attach_data_ptr; call cleanup_attachment (code); ips_mask = ""b; on condition (any_other) call any_other_handler (); call hcs_$set_ips_mask (((36)"0"b), ips_mask); iocb_ptr -> iocb.attach_descrip_ptr = null (); /* it's detached */ call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); P_code = code; /* in case trouble freeing the channel */ return; /* */ /* Write data records to the remote Multics: formats the user's data stream into IMFT physical records and transmits them to the remote Multics. The IMFT physical record format is designed so that one put_chars call on this system will be converted into one get_chars (or get_line) call on the remote. If any errors are detected while writing, this I/O module signals the "imft_write_abort_" condition which imft_transmit_object_ handles through the "get_abort_info" control order */ imft_io_put_chars: entry (P_iocb_ptr, P_data_ptr, P_data_lth, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; code = 0; if iad.input_direction then do; /* can't write the input side of a pipe */ P_code = error_table_$invalid_write; return; end; call transmit_logical_data_record (IMFT_DATA, P_data_ptr, P_data_lth); /* does the actual work */ P_code = code; return; /* */ /* Read data records from the remote Multics: reads requested number of data characters from the remote system. Data is read until either the user's buffer is filled or a control record is encountered. If a control record is read before any data is found or an I/O error occurs during a read, the condition "imft_read_abort_" is signalled which is recognized by the caller. The reason for the termination of the read request can be determined by the "get_abort_info" control order */ imft_io_get_chars: entry (P_iocb_ptr, P_buffer_ptr, P_buffer_max_lth, P_data_lth, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; if ^iad.input_direction then do; /* attempt to read the "punch" */ P_code = error_table_$invalid_read; return; end; call receive_logical_data_records (P_buffer_ptr, P_buffer_max_lth, P_data_lth); P_code = 0; /* here iff successful */ return; /* */ /* Perform control operations on an I/O switch attached for file transfer */ imft_io_control: entry (P_iocb_ptr, P_order, P_info_ptr, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; iad_ptr = iocb_ptr -> iocb.attach_data_ptr; order = P_order; info_ptr = P_info_ptr; code = 0; if order = "write_command_record" then do; /* Write a command record: Commands are sent by an output driver to the remote system's input driver to instruct the input driver as to what it should do next (begin reception of an object, abort, synchronize, etc.) */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version; else if iad.input_direction then /* must be transmitting data */ code = error_table_$invalid_write; else do; icri_ptr = info_ptr; if icri.timeout > 0 then do; /* trap no response */ call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout); on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); end; call transmit_logical_control_record ((icri.record_type), icri.record_ptr, icri.record_lth, code); call timer_manager_$reset_alarm_call (read_write_timeout); end; end; else if order = "read_command_record" then do; /* Read a command record: any intervening data records are discarded */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version; else if ^iad.input_direction then /* must be receiving data to receive control records */ code = error_table_$invalid_read; else do; icri_ptr = info_ptr; if icri.timeout > 0 then do; /* trap no response */ call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout); on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); end; call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth, icri.record_type, code); call timer_manager_$reset_alarm_call (read_write_timeout); end; end; else if order = "write_reply_record" then do; /* Write a reply record: Reply records are often sent by an input driver in response to a command record and indicate the input driver's reasons for accepting or rejecting a command */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version; else if ^iad.input_direction then /* must be receive side of a connection */ code = error_table_$invalid_write; else do; icri_ptr = info_ptr; if icri.timeout > 0 then do; /* trap no response */ call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout); on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); end; call transmit_logical_control_record ((icri.record_type), icri.record_ptr, icri.record_lth, code); call timer_manager_$reset_alarm_call (read_write_timeout); end; end; else if order = "read_reply_record" then do; /* Read a reply record */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version; else if iad.input_direction then /* must be transmitting side of connection */ code = error_table_$invalid_read; else do; icri_ptr = info_ptr; if icri.timeout > 0 then do; /* trap no response */ call timer_manager_$alarm_call ((icri.timeout), RELATIVE_SECONDS, read_write_timeout); on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); end; call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth, icri.record_type, code); call timer_manager_$reset_alarm_call (read_write_timeout); end; end; else if order = "get_abort_info" then do; /* Return cause of previous get_chars or put_chars failure */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> icri.version ^= ICRI_VERSION_1 then code = error_table_$unimplemented_version; else do; icri_ptr = info_ptr; if iad.abort_in_progress then do; /* something did indeed go wrong */ iad.abort_in_progress = "0"b; if (iad.abort_code ^= 0) & (iad.abort_code ^= imft_et_$reply_pending) then do; /* I/O error during read/write */ icri.record_type = IMFT_ABORT; abort_command_ptr = icri.record_ptr; abort_command.reason = IMFT_ABORT_IO_ERROR; abort_command.code = iad.abort_code; icri.record_lth = 4 * currentsize (abort_command); end; /* let caller see exact error */ else do; /* encountered a control record: return it */ call timer_manager_$alarm_call (ONE_MINUTE, RELATIVE_SECONDS, read_write_timeout); on condition (cleanup) call timer_manager_$reset_alarm_call (read_write_timeout); call receive_logical_control_record (icri.record_ptr, icri.record_max_lth, icri.record_lth, icri.record_type, code); call timer_manager_$reset_alarm_call (read_write_timeout); end; end; else code = error_table_$no_operation; /* no abort was happening */ end; end; else if order = "get_channel_names" then do; /* Return the names of the channels attached through this switch */ if info_ptr = null () then code = error_table_$null_info_ptr; else if info_ptr -> get_channel_names.version ^= GET_CHANNEL_NAMES_VERSION_1 then code = error_table_$unimplemented_version; else do; get_channel_names_ptr = info_ptr; local_tgci.version = tty_get_channel_info_version; call iox_$control (iad.input_switch.terminal_iocb_ptr, "get_channel_info", addr (local_tgci), code); if code = 0 then do; /* got the input channel ... */ get_channel_names.input_channel = local_tgci.channel_name; call iox_$control (iad.output_switch.terminal_iocb_ptr, "get_channel_info", addr (local_tgci), code); if code = 0 then /* ... and got the output channel */ get_channel_names.output_channel = local_tgci.channel_name; end; if code ^= 0 then /* couldn't get one of the channel names */ if code = error_table_$undefined_order_request then code = imft_et_$cant_get_channel_names; end; end; else if (order = "read_status") | (order = "resetread") then call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code); /* always apply these to the input connection */ else if (order = "write_status") | (order = "resetwrite") | (order = "runout") then call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code); /* always apply these to the output connection */ else if order = "abort" then do; /* always apply this to both switches */ call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code); call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code); end; else do; /* pass others on to the appropriate half of the connection */ if iad.input_direction then call iox_$control (iad.input_switch.terminal_iocb_ptr, order, info_ptr, code); else call iox_$control (iad.output_switch.terminal_iocb_ptr, order, info_ptr, code); end; RETURN_FROM_IMFT_CONTROL: P_code = code; return; /* */ /* Internal procedure which is invoked when a read/write of a command/reply record times out */ read_write_timeout: procedure (); code = imft_et_$timeout; if iad.debug_mode then /* give the programmer a chance when debugging */ signal condition (imft_debug_); go to RETURN_FROM_IMFT_CONTROL; end read_write_timeout; /* */ /* Change modes: no modes are supported */ imft_io_modes: entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code); iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr; P_old_modes = ""; /* no modes are reflected to caller */ if P_new_modes = "" then P_code = 0; else P_code = error_table_$bad_mode; return; /* */ /* Cleanup whatever portion of an attachment exists */ cleanup_attachment: procedure (P_code); dcl P_code fixed binary (35) parameter; /* a parameter to allow callers to ignore it */ P_code = 0; if iad_ptr ^= null () then do; /* there is an I/O switch */ if iad.input_switch.terminal_iocb_ptr ^= null () then do; call iox_$close (iad.input_switch.terminal_iocb_ptr, (0)); call iox_$detach_iocb (iad.input_switch.terminal_iocb_ptr, P_code); call iox_$destroy_iocb (iad.input_switch.terminal_iocb_ptr, (0)); iad.input_switch.terminal_iocb_ptr = null (); end; if iad.output_switch.terminal_iocb_ptr ^= null () then do; call iox_$close (iad.output_switch.terminal_iocb_ptr, (0)); call iox_$detach_iocb (iad.output_switch.terminal_iocb_ptr, P_code); call iox_$destroy_iocb (iad.output_switch.terminal_iocb_ptr, (0)); iad.output_switch.terminal_iocb_ptr = null (); end; free iad in (system_area); iad_ptr = null (); end; return; end cleanup_attachment; /* */ /* Wrapper to protect against errors while IPS interrupts are masked */ any_other_handler: procedure () options (non_quick); if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask); ips_mask = ""b; call continue_to_signal_ ((0)); /* not interested, */ return; end any_other_handler; /* Abort a call to the attach entry: print an error message if requested */ abort_attachment: procedure () options (variable, non_quick); dcl the_code fixed binary (35) based (the_code_ptr); dcl the_code_ptr pointer; dcl caller_message character (256); call cu_$arg_ptr (1, the_code_ptr, (0), (0)); if loud_sw then do; /* an error message is requested */ call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, (0), "1"b, "0"b); call com_err_ (the_code, IMFT_IO_, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message); end; call cleanup_attachment ((0)); /* get rid of anything that was accomplished */ if the_code = 0 then code = error_table_$action_not_performed; else code = the_code; /* save the error code */ go to RETURN_FROM_ATTACH; end abort_attachment; /* */ /* Fetch the next argument from the attach options and validate that it is a non-null character string */ get_string_argument: procedure () returns (character (*)); dcl option_name character (32); option_name = argument; /* about to move on to the next one */ if argument_idx = hbound (P_attach_options, 1) then call abort_attachment (error_table_$noarg, "Character string following ""^a"".", option_name); argument_idx = argument_idx + 1; argument_ptr = substraddr (P_attach_options (argument_idx), 1); argument_lth = length (P_attach_options (argument_idx)); if argument = "" then call abort_attachment (0, "Character string following ""^a"" must be non-null.", option_name); return (argument); end get_string_argument; /* */ /* Transmit a logical record to the remote system as multiple physical records */ transmit_logical_record: procedure (); return; /* not an entry */ /* Parameters */ dcl P_logical_record_type fixed binary (7) unaligned unsigned parameter; /* type of record being transmitted */ dcl P_logical_record_data_ptr pointer parameter; /* -> the logical record */ dcl P_logical_record_data_lth fixed binary (21) parameter; /* length of logical record in characters */ dcl P_code fixed binary (35) parameter; /* control: status code */ /* Remaining declarations */ dcl logical_record_data character (logical_record_data_lth) unaligned based (logical_record_data_ptr); dcl logical_record_data_lth fixed binary (21); dcl logical_record_data_ptr pointer; dcl logical_record_data_bits bit (logical_record_data_n_bits) unaligned based (logical_record_data_ptr); dcl logical_record_data_bits_lth fixed binary (24); dcl bytes_array (n_bytes) bit (7) unaligned based (bytes_array_ptr); dcl n_bytes fixed binary; dcl bytes_array_ptr pointer; dcl 1 trsi aligned like tty_read_status_info automatic; dcl put_chars_operation bit (1) aligned; /* ON => iox_$put_chars (data records) */ dcl (amount_sent, amount_left) fixed binary (24); /* may hold bit counters */ dcl amount_to_send fixed binary (14); dcl fb14uu fixed binary (14) unaligned unsigned; dcl based_character character (1) unaligned based; dcl idx fixed binary; /* Transmit a data record: aborts by signalling imft_write_abort_ if an I/O error is encountered */ transmit_logical_data_record: entry (P_logical_record_type, P_logical_record_data_ptr, P_logical_record_data_lth); put_chars_operation = "1"b; go to TRANSMIT_COMMON; /* Transmit a control record: any errors are reflected to the caller */ transmit_logical_control_record: entry (P_logical_record_type, P_logical_record_data_ptr, P_logical_record_data_lth, P_code); P_code = 0; put_chars_operation = "0"b; TRANSMIT_COMMON: if ^iad.input_direction then do; /* output side: check for unexpected replies */ trsi.input_pending = "0"b; /* ... in case the next call fails */ call iox_$control (iad.input_switch.terminal_iocb_ptr, "read_status", addr (trsi), (0)); if trsi.input_pending then call abort_write_operation (imft_et_$reply_pending); end; logical_record_data_ptr = P_logical_record_data_ptr; logical_record_data_lth = P_logical_record_data_lth; terminal_io_record_ptr = addr (iad.output_switch.tior); ipr_ptr = addr (terminal_io_record.data); unspec (imft_physical_record) = ""b; /* start out clean */ imft_physical_record.record_type = P_logical_record_type; if logical_record_data_lth > 0 then imft_physical_record.binary = (verify (logical_record_data, collate ()) ^= 0); amount_sent = 0; if logical_record_data_lth = 0 then do; /* empty record: transmit header only */ imft_physical_record.bolr, /* this is the entire logical record */ imft_physical_record.eolr = "1"b; call transmit_physical_record (); end; else if imft_physical_record.binary then do; /* Binary data: unpack 7 bits at a time into 9 bit forming valid ASCII characters for transmission. At some future time, support for binary transmission should be provided */ logical_record_data_bits_lth = N_BITS_PER_CHARACTER * logical_record_data_lth; do while (amount_sent < logical_record_data_bits_lth); amount_left = logical_record_data_bits_lth - amount_sent; amount_to_send = min (amount_left, IMFT_PHYSICAL_RECORD_DATA_BITS_LTH); /* are using 7 bits per character */ n_bytes = divide (amount_to_send + 6, 7, 17, 0); bytes_array_ptr = add_bit_offset_ (logical_record_data_ptr, (amount_sent)); /* first bit to go into this record */ do idx = 1 to n_bytes; if idx = n_bytes then /* special case last byte */ if mod (amount_to_send, 7) ^= 0 then unspec (substraddr (imft_physical_record.data, (idx)) -> based_character) = "00"b || substr (bytes_array (idx), 1, mod (amount_to_send, 7)); else unspec (substraddr (imft_physical_record.data, (idx)) -> based_character) = "00"b || bytes_array (idx); else unspec (substraddr (imft_physical_record.data, (idx)) -> based_character) = "00"b || bytes_array (idx); end; fb14uu = amount_to_send; /* record # of bits transmitted */ imft_physical_record.n_els.high_order = substr (unspec (fb14uu), 1, 7); imft_physical_record.n_els.low_order = substr (unspec (fb14uu), 8, 7); if amount_sent = 0 then /* first physical record of logical record */ imft_physical_record.bolr = "1"b; if amount_to_send = amount_left then /* last physical record */ imft_physical_record.eolr = "1"b; call transmit_physical_record (); /* zap! */ amount_sent = amount_sent + amount_to_send; end; end; else do; /* Character only data */ do while (amount_sent < logical_record_data_lth); amount_left = logical_record_data_lth - amount_sent; amount_to_send = min (amount_left, IMFT_PHYSICAL_RECORD_DATA_LTH); /* determine how much to send now */ imft_physical_record.data = substr (logical_record_data, (amount_sent + 1), amount_to_send); fb14uu = amount_to_send; /* put # of characters in record into the record */ imft_physical_record.n_els.high_order = substr (unspec (fb14uu), 1, 7); imft_physical_record.n_els.low_order = substr (unspec (fb14uu), 8, 7); if amount_sent = 0 then /* first physical record of logical one */ imft_physical_record.bolr = "1"b; if amount_to_send = amount_left then /* last physical record */ imft_physical_record.eolr = "1"b; call transmit_physical_record (); /* zap! */ amount_sent = amount_sent + amount_to_send; end; end; if ^put_chars_operation then /* here iff all written OK */ P_code = 0; RETURN_FROM_TRANSMIT_LOGICAL_RECORD: return; /* Internal to transmit_logical_record: transmits a single physical record to the remote system */ transmit_physical_record: procedure (); dcl saved_record_type fixed binary; dcl saved_binary_flag bit (1) aligned; dcl code fixed binary (35); saved_record_type = imft_physical_record.record_type; saved_binary_flag = imft_physical_record.binary; terminal_io_record.element_size = 9; terminal_io_record.n_elements = IMFT_PHYSICAL_RECORD_LTH; /* make sure they're still correct */ call iox_$write_record (iad.output_switch.terminal_iocb_ptr, terminal_io_record_ptr, (4 * currentsize (terminal_io_record)), code); if code ^= 0 then call abort_write_operation (code); unspec (imft_physical_record) = ""b; /* start next record clean */ imft_physical_record.record_type = saved_record_type; imft_physical_record.binary = saved_binary_flag; return; /* it won */ end transmit_physical_record; /* Internal to transmit_logical_record: aborts the current write operation */ abort_write_operation: procedure (p_code); dcl p_code fixed binary (35) parameter; if put_chars_operation then do; /* data stream: abort the operation completely */ iad.abort_in_progress = "1"b; iad.abort_code = p_code; SIGNAL_TRANSMISSION_FAILURE_FOREVER: signal condition (imft_write_abort_); go to SIGNAL_TRANSMISSION_FAILURE_FOREVER; end; /* imft_transmit_object_ shouldn't return */ else do; /* writing a control record: reflect error to caller */ P_code = p_code; go to RETURN_FROM_TRANSMIT_LOGICAL_RECORD; end; end abort_write_operation; end transmit_logical_record; /* */ /* Receive the contents of a logical record from the remote system */ receive_logical_record: procedure (); return; /* not an entry */ dcl P_buffer_ptr pointer parameter; /* -> buffer to place record contents */ dcl P_buffer_max_lth fixed binary (21) parameter; /* maximum size of buffer (in characters) */ dcl P_buffer_used fixed binary (21) parameter; /* # of characters placed into buffer */ dcl P_record_type fixed binary parameter; /* control: set to type of control record found */ dcl P_code fixed binary (35) parameter; /* control: status cod */ /* Remaining declarations */ dcl buffer bit (buffer_max_lth) unaligned based (buffer_ptr); dcl (buffer_used, buffer_max_lth) fixed binary (24); dcl buffer_ptr pointer; dcl buffer_as_chars character (P_buffer_max_lth) unaligned based (buffer_ptr); dcl 1 byte_structure aligned, 2 pad bit (2) unaligned, 2 byte bit (7) unaligned; dcl get_chars_operation bit (1) aligned; /* ON => reading data stream */ dcl continue bit (1) aligned; dcl (space_left, amount_left, amount_to_copy, amount_done) fixed binary (24); dcl (characters_used, characters_to_copy) fixed binary (21); dcl byte_idx fixed binary (21); dcl n_bits_from_byte fixed binary; /* Receive data records: aborts by signalling imft_read_abort_ if an I/O error is encountered or the previous read operation terminated with a control record */ receive_logical_data_records: entry (P_buffer_ptr, P_buffer_max_lth, P_buffer_used); get_chars_operation = "1"b; go to RECEIVE_COMMON; /* Receive a control record: flushes all data records until a control record is found and returned */ receive_logical_control_record: entry (P_buffer_ptr, P_buffer_max_lth, P_buffer_used, P_record_type, P_code); P_record_type = -1; /* haven't found it yet */ P_code = 0; get_chars_operation = "0"b; RECEIVE_COMMON: buffer_ptr = P_buffer_ptr; buffer_max_lth = N_BITS_PER_CHARACTER * P_buffer_max_lth; buffer_used = 0; terminal_io_record_ptr = addr (iad.input_switch.tior); ipr_ptr = addr (terminal_io_record.data); continue = "1"b; do while (continue); if iad.input_switch.current_physical_record_type = -1 then READ_ANOTHER_RECORD: call receive_physical_record (); if iad.input_switch.current_physical_record_type = IMFT_DATA then if get_chars_operation then ; /* data record OK */ else go to READ_ANOTHER_RECORD; /* data records should be ignored */ else /* control record ... */ if get_chars_operation then /* ... while reading data ... */ if buffer_used = 0 then /* ... is only fatal if first read */ call abort_read_operation (0); else go to END_OF_GET_CHARS; /* in middle of stream: end of get_chars */ if ^get_chars_operation then /* if reading control records ... */ if P_record_type = -1 then /* ... and haven't determined type yet */ P_record_type = iad.input_switch.current_physical_record_type; if iad.input_switch.current_physical_record_n_els = 0 then ; /* nothing in this record to unpack or copy */ else if imft_physical_record.binary then do; /* Binary data: pack low order 7-bits of each character into the caller's buffer as a continuous bit stream */ if buffer_used < buffer_max_lth then do; space_left = buffer_max_lth - buffer_used; amount_left = iad.input_switch.current_physical_record_n_els - iad.input_switch.current_physical_record_used; amount_to_copy = min (space_left, amount_left); amount_done = 0; do while (amount_done < amount_to_copy); byte_idx = divide (iad.input_switch.current_physical_record_used, 7, 17, 0) + 1; n_bits_from_byte = min ((amount_to_copy - amount_done), 7); unspec (byte_structure) = unspec (substr (imft_physical_record.data, byte_idx, 1)); substr (buffer, (buffer_used + 1), n_bits_from_byte) = substr (byte_structure.byte, (mod (iad.input_switch.current_physical_record_used, 7) + 1), n_bits_from_byte); buffer_used = buffer_used + n_bits_from_byte; iad.input_switch.current_physical_record_used = iad.input_switch.current_physical_record_used + n_bits_from_byte; amount_done = amount_done + n_bits_from_byte; end; end; end; else do; /* Character data: copy it to caller's buffer */ call adjust_buffer_used (); /* make sure it's integral # of characters */ characters_used = divide ((buffer_used + N_BITS_PER_CHARACTER - 1), N_BITS_PER_CHARACTER, 21, 0); if buffer_used < buffer_max_lth then do; space_left = buffer_max_lth - buffer_used; amount_left = N_BITS_PER_CHARACTER * (iad.input_switch.current_physical_record_n_els - iad.input_switch.current_physical_record_used); amount_to_copy = min (space_left, amount_left); characters_to_copy = divide ((amount_to_copy + N_BITS_PER_CHARACTER - 1), N_BITS_PER_CHARACTER, 21, 0); substr (buffer_as_chars, (characters_used + 1), characters_to_copy) = substr (imft_physical_record.data, (iad.input_switch.current_physical_record_used + 1), characters_to_copy); buffer_used = buffer_used + amount_to_copy; iad.input_switch.current_physical_record_used = iad.input_switch.current_physical_record_used + characters_to_copy; end; end; if iad.input_switch.current_physical_record_used >= iad.input_switch.current_physical_record_n_els then iad.input_switch.current_physical_record_type = -1; if ^get_chars_operation & imft_physical_record.eolr then continue = "0"b; /* got it all */ continue = continue & (buffer_used < buffer_max_lth); end; END_OF_GET_CHARS: call adjust_buffer_used (); /* make sure it's integral # of characters */ P_buffer_used = divide ((buffer_used + N_BITS_PER_CHARACTER - 1), N_BITS_PER_CHARACTER, 21, 0); RETURN_FROM_RECEIVE_LOGICAL_RECORD: return; /* Internal to receive_logical_record: receives a single physical record */ receive_physical_record: procedure (); dcl fb14uu fixed binary (14) unaligned unsigned; dcl code fixed binary (35); terminal_io_record.element_size = 9; terminal_io_record.n_elements = IMFT_PHYSICAL_RECORD_LTH; call iox_$read_record (iad.input_switch.terminal_iocb_ptr, terminal_io_record_ptr, (4 * currentsize (terminal_io_record)), (0), code); if code ^= 0 then call abort_read_operation (code); if terminal_io_record.n_elements ^= IMFT_PHYSICAL_RECORD_LTH then call abort_read_operation (error_table_$short_record); iad.input_switch.current_physical_record_type = imft_physical_record.record_type; unspec (fb14uu) = imft_physical_record.n_els.high_order || imft_physical_record.n_els.low_order; iad.input_switch.current_physical_record_n_els = fb14uu; /* record # of characters or bytes */ iad.input_switch.current_physical_record_used = 0; /* haven't taken any */ if imft_physical_record.bolr & ^get_chars_operation then if buffer_used ^= 0 then /* missed end of control record */ call abort_read_operation (error_table_$improper_data_format); return; end receive_physical_record; /* Internal to receive_logical_record: aborts the current read operation */ abort_read_operation: procedure (p_code); dcl p_code fixed binary (35) parameter; if get_chars_operation then do; /* get_chars (data stream): signal imft_read_abort_ */ iad.abort_in_progress = "1"b; iad.abort_code = p_code; SIGNAL_RECEIVE_FAILURE_FOREVER: signal condition (imft_read_abort_); go to SIGNAL_RECEIVE_FAILURE_FOREVER; end; else do; /* reading control record: return code to caller */ P_code = p_code; go to RETURN_FROM_RECEIVE_LOGICAL_RECORD; end; end abort_read_operation; /* Internal to receive_logical_record: adjusts buffer_used to be an integral # of characters */ adjust_buffer_used: procedure (); dcl n_bits_to_zero fixed binary; if mod (buffer_used, N_BITS_PER_CHARACTER) ^= 0 then do; n_bits_to_zero = N_BITS_PER_CHARACTER - mod (buffer_used, N_BITS_PER_CHARACTER); substr (buffer, (buffer_used + 1), n_bits_to_zero) = ""b; /* insure no garbage in buffer */ buffer_used = buffer_used + n_bits_to_zero; end; return; end adjust_buffer_used; end receive_logical_record; /* */ /* substraddr: Return a pointer to the specified character of a varying or nonvarying string. When the substraddr builtin function is finally implemented, these internal procedures should be removed */ dcl substraddr generic (substraddr_nonvarying when (character (*) nonvarying, fixed binary precision (1:35)), substraddr_varying when (character (*) varying, fixed binary precision (1:35))); substraddr_nonvarying: procedure (P_string, P_position) returns (pointer); dcl P_string character (*) nonvarying parameter; dcl P_position fixed binary (21) parameter; dcl string_overlay (length (P_string)) character (1) unaligned based (addr (P_string)); return (addr (string_overlay (P_position))); end substraddr_nonvarying; substraddr_varying: procedure (P_string, P_position) returns (pointer); dcl P_string character (*) varying parameter; dcl P_position fixed binary (21) parameter; dcl 1 string_overlay aligned based (addr (P_string)), 2 lth fixed binary (21), 2 characters (0 refer (string_overlay.lth)) character (1) unaligned; return (addr (string_overlay.characters (P_position))); end substraddr_varying; /* */ %include iocb; %page; %include iox_modes; %page; %include terminal_io_record; %include tty_read_status_info; %include tty_get_channel_info; %page; %include "_imft_cri"; %include "_imft_get_channel_names"; %page; %include "_imft_std_commands"; end old_imft_io_;  print_imft_sites.pl1 10/28/88 1409.0rew 10/28/88 1232.0 67824 /****^ ******************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * ******************************************** */ /* format: style4 */ print_imft_sites: pis: procedure; /* This command prints the names of all foreign sites usable with the "-source" or "-destination" control argument to the enter_imft_request etc. commands. It does this by finding out the names of the request types, and assuming that destinations are represented by request type names of the form "To_SITE", and sources by names of the form "From_SITE". */ /* Written March 1983 by Robert Coren */ /****^ HISTORY COMMENTS: 1) change(88-08-24,Brunelle), approve(88-08-24,MCR7911), audit(88-10-21,Wallman), install(88-10-28,MR12.2-1199): Upgraded to version 5 iod tables. Changed column widths to that needed by the longest entry in column. Added display of comment field. END HISTORY COMMENTS */ /* External Procedures & Variables */ dcl com_err_ entry () options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl error_table_$too_many_args fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl imft_default_rqt_ entry () returns (char (*)); dcl imft_data_$queue_dirname char (168) external static; dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ioa_ entry () options (variable); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl cleanup condition; dcl (addr, after, length, max, null, ptr, rtrim, substr, unspec) builtin; /* Internal Static */ dcl IODT_NAME char (32) internal static options (constant) init ("iod_working_tables"); dcl PRINT_IMFT_SITES char (16) internal static options (constant) init ("print_imft_sites"); /* Automatic */ dcl access_id_offset fixed bin; /* offset for ioa_ statement */ dcl bc fixed bin (24); /* initiate_file_ bitcount */ dcl code fixed bin (35); /* general error code */ dcl default_site character (32); /* temp storage for default site name */ dcl dest_offset fixed bin; /* offset for ioa_ statement */ dcl dest_type bit (1); /* ON if available as destination */ dcl n_args fixed bin; /* # of args called with */ dcl n_sites fixed bin; /* count of imft sites found in the tables */ dcl qgt_size fixed bin; /* # of entries in queue group tables */ dcl qgtx fixed bin; /* queue group table index */ dcl site_name char (32); /* temp name of the site */ dcl sitex fixed bin; /* temp site index */ dcl source_type bit (1); /* ON if available as source */ %page; call cu_$arg_count (n_args, code); if code ^= 0 then do; /* something wrong -- we're not allowed to be an AF */ call com_err_ (code, PRINT_IMFT_SITES); return; end; if n_args > 0 then do; /* nor are we supposed to get arguments */ call com_err_ (error_table_$too_many_args, PRINT_IMFT_SITES, "^/Usage: print_imft_sites"); return; end; ithp = null (); on condition (cleanup) call cleanup_proc; call initiate_file_ (imft_data_$queue_dirname, IODT_NAME, R_ACCESS, ithp, bc, code); if ithp = null () then do; call com_err_ (code, PRINT_IMFT_SITES, "Could not initiate ^a", pathname_ (imft_data_$queue_dirname, IODT_NAME)); return; end; if iod_tables_hdr.version ^= IODT_VERSION_5 then do; call com_err_ (error_table_$unimplemented_version, PRINT_IMFT_SITES, "^a is not a proper iod_tables segment.", pathname_ (imft_data_$queue_dirname, IODT_NAME)); call cleanup_proc; return; end; default_site = after (imft_default_rqt_ (), "To_"); qgtp = ptr (ithp, iod_tables_hdr.q_group_tab_offset); qgt_size = q_group_tab.n_q_groups; %page; INNER_BLOCK: begin; /* so as to get large enough automatic array for all possible request type names */ dcl 1 site_desc aligned, 2 max_name_length fixed bin, 2 max_driver_name_length fixed bin, 2 max_comment_length fixed bin, 2 ents (qgt_size) aligned, 3 name character (32), 3 driver_name character (32), /* access name of I/O daemon driver */ 3 flags, 4 destination bit (1) unaligned, /* ON => usable as a destination */ 4 source bit (1) unaligned, /* ON => usable as a source */ 4 default bit (1) unaligned, /* ON => this is default site */ 4 pad bit (33) unaligned; n_sites = 0; unspec (site_desc) = "0"b; do qgtx = 1 to qgt_size; qgtep = addr (q_group_tab.entries (qgtx)); if qgte.generic_type = FT_GENERIC_TYPE then if qgte.name ^= FT_GENERIC_TYPE then do; /* name used to indicate default is not interesting */ if substr (qgte.name, 1, 3) = "To_" then do; site_name = substr (qgte.name, 4); source_type = "0"b; dest_type = "1"b; end; else if substr (qgte.name, 1, 5) = "From_" then do; site_name = substr (qgte.name, 6); source_type = "1"b; dest_type = "0"b; end; else do; call com_err_ (0, PRINT_IMFT_SITES, "Request type ""^a"" has a generic type of ""^a"" but its name is not of standard form." , qgte.name, FT_GENERIC_TYPE); go to NEXT_QGTE; /* skip it */ end; /* now find out if we've already found a request type for this site */ do sitex = 1 to n_sites while (site_desc (sitex).name ^= site_name); end; if sitex > n_sites then do; /* didn't find it */ n_sites = sitex; site_desc (sitex).name = site_name; site_desc (sitex).driver_name = qgte.driver_id; if length (rtrim (site_name)) > site_desc.max_name_length then site_desc.max_name_length = length (rtrim (site_name)); if length (rtrim (qgte.driver_id)) > site_desc.max_driver_name_length then site_desc.max_driver_name_length = length (rtrim (qgte.driver_id)); end; if source_type then site_desc (sitex).source = "1"b; if dest_type then do; site_desc (sitex).destination = "1"b; if site_name = default_site then site_desc (sitex).default = "1"b; end; end; NEXT_QGTE: end; if n_sites = 0 then call ioa_ ("No site names found in ^a.", pathname_ (imft_data_$queue_dirname, IODT_NAME)); else do; call sort_sites; access_id_offset = site_desc.max_name_length + 11 + 2; dest_offset = site_desc.max_name_length + 11 + 2 + max (9, site_desc.max_driver_name_length) + 2; call ioa_ ("Site name^vtAccess ID^vtDest Source^/", access_id_offset, dest_offset); do sitex = 1 to n_sites; call ioa_ ("^a^[ (default)^;^]^vt^a^vt^[ X^; ^] ^[ X^;^]", site_desc (sitex).name, site_desc (sitex).default, access_id_offset, site_desc (sitex).driver_name, dest_offset, site_desc (sitex).destination, site_desc (sitex).source); end; end; sort_sites: procedure; /*** TO BE SUPPLIED ***/ end sort_sites; end INNER_BLOCK; call cleanup_proc; return; %page; cleanup_proc: procedure; if ithp ^= null () then do; call hcs_$terminate_noname (ithp, (0)); ithp = null (); return; end; end cleanup_proc; %page; %include "_imft_ft_request"; %page; %include access_mode_values; %page; %include iod_tables_hdr; %page; %include q_group_tab; %page; %include queue_msg_hdr; end print_imft_sites; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved