l6_tran_.pl1 04/09/85 1708.8r w 04/08/85 1129.1 532854 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /******************************************************************************/ /* */ /* DESCRIPTION: */ /* */ /* This subroutine is the NASP (see MTB 538) which implements file */ /* transfer to the Level 6 over an X.25 channel. */ /* */ /* */ /* JOURNALIZATION: */ /* */ /* 1) Written 3/82 by R.J.C Kissel */ /* 2) Modified 7/83 by R.J.C. Kissel to handle passwords for Mod 400 */ /* Release 21. and 3.0, and also fix an error message to the L6. */ /* 3) Modified 9/83 by R.J.C. Kissel to fix a bug in handling L6 pathnames. */ /* */ /******************************************************************************/ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */ l6_tran_: proc (); RETURN: /* Label for error returns. */ return; /* Parameters */ dcl P_arg_list_ptr ptr parameter; dcl P_area_ptr ptr parameter; /* Null means use the system free area. */ dcl P_caller_name char (*) parameter; dcl P_code fixed bin (35) parameter; dcl P_complete bit (1) parameter; /* "1"b -- request is complete, "0"b -- not complete */ dcl P_error_message char (*) varying parameter; dcl P_first_arg fixed bin parameter; dcl P_in_iocbp ptr parameter; dcl P_list_flag bit (1) parameter; /* "1"b -- list this request, "0"b -- don't list it */ dcl P_nasp_info_ptr ptr parameter; dcl P_output_lines char (*) varying parameter; dcl P_out_iocbp ptr parameter; dcl P_queued_flag bit (1) parameter; /* "1"b -- request from queue, "0"b -- interactive request */ dcl P_structure_len fixed bin (24) parameter; /* In bits */ dcl P_structure_ptr ptr parameter; dcl P_unhold bit (1) parameter; /* "1"b -- update held requests, "0"b -- don't update them */ /* Automatic */ dcl 1 auto_status_branch aligned like status_branch; dcl 1 auto_transfer_input_args aligned like transfer_input_args; dcl 1 auto_transfer_output_args aligned like transfer_output_args; dcl arg char (arg_len) based (arg_ptr); dcl arg_idx fixed bin; dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl arg_list_ptr ptr; dcl based_area area (sys_info$max_seg_size) based (area_ptr); dcl area_ptr ptr; dcl caller_name char (32); dcl Cleanup_Handler entry () variable; dcl code fixed bin (35); dcl comm_buffer char (comm_buffer_len) based (comm_buffer_ptr); dcl comm_buffer_len fixed bin (21); dcl comm_buffer_ptr ptr defined (temp_seg_ptrs (1)); dcl complete_flag bit (1); dcl file_buffer char (file_buffer_len) based (file_buffer_ptr); dcl file_buffer_len fixed bin (21); dcl file_buffer_ptr ptr defined (temp_seg_ptrs (2)); dcl first_arg fixed bin; dcl i fixed bin; dcl ignored_len fixed bin (21); /* Used in calls to ioa_$rsnnl. */ dcl in_iocbp ptr; dcl last_file bit (1); dcl level_6_attach_desc char (128) varying; dcl level_6_chars_read fixed bin (21); dcl level_6_chars_to_write fixed bin (21); dcl level_6_data_type fixed bin; dcl level_6_dir char (168); dcl level_6_entry char (32); dcl level_6_file_type fixed bin; dcl level_6_iocbp ptr; dcl level_6_max_record_size fixed bin; dcl level_6_pathname char (168); dcl level_6_response_pathname char (168); dcl list_flag bit (1); dcl multics_chars_read fixed bin (21); dcl multics_chars_to_write fixed bin (21); dcl multics_dir char (168); dcl multics_entry char (32); dcl multics_file_attach_desc char (256) varying; dcl multics_file_block_size fixed bin (21); dcl multics_file_iocbp ptr; dcl multics_file_l6_type fixed bin; dcl multics_file_type fixed bin; dcl multics_file_open_mode fixed bin; dcl multics_file_size fixed bin (34); dcl multics_is_sender bit (1); dcl multics_pathname char (168); dcl number_of_args fixed bin; dcl output_lines char (256) varying; dcl out_iocbp ptr; dcl queued_flag bit (1); dcl saved_attributes char (256) varying; dcl saved_level_6_entry char (32); dcl saved_multics_entry char (32); dcl star_area_ptr ptr; dcl star_entries_index fixed bin; dcl star_names_generated bit (1); dcl suffix char (32); dcl temp_seg_ptrs (2) ptr; dcl total_time fixed bin (71); dcl unhold_flag bit (1); dcl 1 info aligned like indx_info;/* Use the biggest structure. */ /* The l6_tran_ shared structure */ dcl l6tip ptr; dcl l6_tran_info_v1 fixed bin (35) internal static options (constant) init (1); dcl 1 l6_tran_info aligned based (l6tip), 2 version fixed bin (35), 2 sender_info aligned, 3 pathname char (168) unaligned, 3 host_name char (32) unaligned, 2 receiver_info aligned, 3 pathname char (168) unaligned, 3 host_name char (32) unaligned, 2 net_name char (32) unaligned, /* Really the channel name. */ 2 net_address char (32) unaligned, /* The call data for an x.25 channel. */ 2 multics_data_type fixed bin, /* 1--ascii, 2--binary, 3--bcd */ 2 user_name char (32) unaligned, 2 password char (12) unaligned, 2 flags aligned, 3 long bit (1) unaligned, /* "1"b--print a transfer message, "0"b--don't print it */ 3 l6_attended bit (1) unaligned, /* "1"b--no login needed, "0"b--login needed */ 3 pad bit (34) unaligned; /* Internal Static */ dcl debug_flag bit (1) internal static init ("0"b); /* Internal Constants */ %include l6_tran_constants; /* External Constants */ dcl error_table_$area_too_small fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$bad_file fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$badpath fixed bin (35) ext static; dcl error_table_$badstar fixed bin (35) ext static; dcl error_table_$dirseg fixed bin (35) ext static; dcl error_table_$fatal_error fixed bin (35) ext static; dcl error_table_$incompatible_file_attribute fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$not_closed fixed bin (35) ext static; dcl error_table_$not_detached fixed bin (35) ext static; dcl error_table_$too_many_args fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (19) ext static; /* External Entries */ dcl add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_count_rel entry (fixed bin, ptr, fixed bin (35)); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35)); dcl get_user_free_area_ entry returns (ptr); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl hcs_$append_branch entry (char (*), char (*), fixed bin (5), fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl ioa_$ioa_switch entry () options (variable); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned); dcl ioa_$rsnnl entry () options (variable); dcl ioa_$rsnpnnl entry options (variable); dcl l6_tran_util_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl l6_tran_util_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl l6_tran_util_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl l6_tran_receive_file_ entry (ptr, ptr, char (*) var, fixed bin (35)); dcl l6_tran_send_file_ entry (ptr, ptr, char (*) var, fixed bin (35)); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl net_info_table_$get_host_address entry (char (*), char (*), char (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl read_password_$switch entry (ptr, ptr, char (*), char (*), fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl suffixed_name_$make entry (char (*), char (*), char (32), fixed bin (35)); dcl vfile_status_ entry (char (*), char (*), ptr, fixed bin (35)); dcl user_info_$whoami entry (char (*), char (*), char (*)); /* Builtin Functions and Conditions */ dcl addr builtin; dcl before builtin; dcl clock builtin; dcl float builtin; dcl hbound builtin; dcl index builtin; dcl lbound builtin; dcl length builtin; dcl min builtin; dcl null builtin; dcl pointer builtin; dcl reverse builtin; dcl rtrim builtin; dcl string builtin; dcl substr builtin; dcl sum builtin; dcl unspec builtin; dcl area condition; dcl cleanup condition; /* Include Files */ %include nasp_info; %include l6_tran_transfer_args; /* vfs_info.incl.pl1 */ %include vfs_info; %include access_mode_values; %include status_structures; %include iox_entries; %include iox_modes; %include star_structures; /******************************************************************************/ /* */ /* ENTRY: parser */ /* */ /* This entry is in charge of taking the user's command line arguments */ /* and building a structure that describes the work to be done. This */ /* structure is used by the other entries so they know what to do. This */ /* entry may ask the user questions if it needs more information. */ /* */ /******************************************************************************/ parser: entry (P_in_iocbp, P_out_iocbp, P_caller_name, P_arg_list_ptr, P_first_arg, P_queued_flag, P_area_ptr, P_structure_ptr, P_structure_len, P_error_message, P_code); in_iocbp = P_in_iocbp; out_iocbp = P_out_iocbp; caller_name = P_caller_name; arg_list_ptr = P_arg_list_ptr; first_arg = P_first_arg; queued_flag = P_queued_flag; area_ptr = P_area_ptr; Cleanup_Handler = Parser_Cleanup; l6tip = null (); level_6_iocbp = null (); /* No messages for the L6 from parser. */ on cleanup call Cleanup_Handler (); /* Make a quick check, since we currently only support interactive request. */ if queued_flag then call ERROR (error_table_$unimplemented_version, "Only interactive requests are currently supported."); if area_ptr = null () then call ERROR (error_table_$bad_arg, "An area pointer must be specified."); /* Allocate the shared structure and parse the command line arguments. */ on area call ERROR (error_table_$area_too_small, "Attempting to allocate the l6_tran_info structure."); allocate l6_tran_info in (based_area); revert area; l6_tran_info.version = l6_tran_info_v1; l6_tran_info.sender_info = ""; l6_tran_info.receiver_info = ""; l6_tran_info.net_name = ""; /* Default */ l6_tran_info.multics_data_type = ASCII; /* Default */ call user_info_$whoami (l6_tran_info.user_name, "", ""); /* Set the default. */ l6_tran_info.password = ""; l6_tran_info.flags = "0"b; /* Reset all of them. */ l6_tran_info.flags.long = "1"b; /* Default */ call cu_$arg_count_rel (number_of_args, arg_list_ptr, code); if code ^= 0 then call ERROR (code); if number_of_args - first_arg + 1 < 4 then call ERROR (error_table_$noarg, "^/^a.", USAGE); if number_of_args - first_arg + 1 > 11 then call ERROR (error_table_$too_many_args, "^/^a.", USAGE); do arg_idx = first_arg to number_of_args; /* Process the arguments. */ call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then call ERROR (code, "Trying to get argument: ^d.", arg_idx); if index (arg, "-") ^= 1 then call Process_File_Name (); else do; /* Process a control arg. */ if arg = "-name" | arg = "-nm" then do; arg_idx = arg_idx + 1; call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then call ERROR (code, "Trying to get the name after a -name argument."); call Process_File_Name (); end; else if arg = "-data_type" then do; arg_idx = arg_idx + 1; call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then call ERROR (code, "Trying to get the data type."); if arg = "ascii" | arg = "ASCII" then l6_tran_info.multics_data_type = ASCII; else if arg = "binary" | arg = "BINARY" then l6_tran_info.multics_data_type = BINARY; else if arg = "bcd" | arg = "BCD" then l6_tran_info.multics_data_type = BCD; else call ERROR (error_table_$bad_arg, "Unrecognized data type: ^a.", arg); end; else if arg = "-long" | arg = "-lg" then l6_tran_info.flags.long = "1"b; else if arg = "-brief" | arg = "-bf" then l6_tran_info.flags.long = "0"b; else if arg = "-attended" | arg = "-att" then l6_tran_info.flags.l6_attended = "1"b; else if arg = "-not_attended" | arg = "-natt" then l6_tran_info.flags.l6_attended = "0"b; else if arg = "-user" then do; arg_idx = arg_idx + 1; call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then call ERROR (code, "Trying to get the user argument."); l6_tran_info.user_name = arg; end; else if arg = "-password" | arg = "-pw" then do; arg_idx = arg_idx + 1; call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then call ERROR (code, "Trying to get the password argument."); l6_tran_info.password = arg; end; else if arg = "-network" | arg = "-net" then do; arg_idx = arg_idx + 1; call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then call ERROR (code, "Trying to get the network (channel) argument."); l6_tran_info.net_name = arg; end; else call ERROR (error_table_$badopt, "Argument: ^a.", arg); end; /* Process a control arg. */ end; /* Process the arguments. */ /* Make some checks to make sure we have everything we need. */ if l6_tran_info.sender_info.pathname = "" then call ERROR (error_table_$noarg, "A source pathname must be specified."); if l6_tran_info.receiver_info.pathname = "" then call ERROR (error_table_$noarg, "A destination pathname must be specified."); if l6_tran_info.sender_info.host_name ^= "" & l6_tran_info.receiver_info.host_name ^= "" then call ERROR (error_table_$too_many_args, "Only one file name may have a host specified with the ""-at"" argument."); if l6_tran_info.net_name = "" then call ERROR (error_table_$noarg, "A network name (X.25 channel name) must be specified."); if l6_tran_info.sender_info.host_name ^= "" then call net_info_table_$get_host_address (l6_tran_info.sender_info.host_name, l6_tran_info.net_name, l6_tran_info.net_address, code); else call net_info_table_$get_host_address (l6_tran_info.receiver_info.host_name, l6_tran_info.net_name, l6_tran_info.net_address, code); if code ^= 0 then call ERROR (code, "Unrecognized host: ^[^a^;^a^].", l6_tran_info.sender_info.host_name ^= "", l6_tran_info.sender_info.host_name, l6_tran_info.receiver_info.host_name); if l6_tran_info.net_address = "" then call ERROR (error_table_$noarg, "Either the source or destination file must specify the ""-at"" argument with a host name (address)." ); P_structure_ptr = l6tip; P_structure_len = length (unspec (l6_tran_info)); /* Length in bits. */ P_error_message = ""; P_code = 0; return; /******************************************************************************/ /* */ /* ENTRY: execute */ /* */ /* This entry is in charge of doing the actual work for a L6 file */ /* transfer. It uses the structure built by the parser entry to find out */ /* what to do. It may communicate with the user or operator to clarify */ /* operations in some cases. */ /* */ /******************************************************************************/ execute: entry (P_in_iocbp, P_out_iocbp, P_caller_name, P_queued_flag, P_structure_ptr, P_structure_len, P_complete, P_unhold, P_error_message, P_code); in_iocbp = P_in_iocbp; out_iocbp = P_out_iocbp; caller_name = P_caller_name; queued_flag = P_queued_flag; l6tip = P_structure_ptr; /* Set things up for the cleanup handler. */ Cleanup_Handler = Execute_Cleanup; status_area_ptr = null (); status_ptr = null (); auto_status_branch.nnames = 0; auto_status_branch.names_relp = "0"b; multics_file_iocbp = null (); level_6_iocbp = null (); file_buffer_ptr = null (); comm_buffer_ptr = null (); star_names_generated = "0"b; star_entry_ptr = null (); star_names_ptr = null (); star_area_ptr = null (); star_entry_count = 0; star_entries_index = 0; on cleanup call Cleanup_Handler (); /* Find out who is sending, and get pathnames. */ if l6_tran_info.sender_info.host_name = "" /* A host name means the Level 6. */ then do; multics_is_sender = "1"b; multics_pathname = l6_tran_info.sender_info.pathname; level_6_pathname = l6_tran_info.receiver_info.pathname; end; else do; multics_is_sender = "0"b; multics_pathname = l6_tran_info.receiver_info.pathname; level_6_pathname = l6_tran_info.sender_info.pathname; end; call expand_pathname_ (multics_pathname, multics_dir, saved_multics_entry, code); if code ^= 0 then call ERROR (code, "Trying to expand multics pathname: ^a.", multics_pathname); multics_pathname = pathname_ (multics_dir, saved_multics_entry); /* "Canonicalize" the pathname for vfile_. */ multics_entry = saved_multics_entry; saved_level_6_entry = reverse (before (reverse (level_6_pathname), ">")); level_6_dir = substr (level_6_pathname, 1, length (rtrim (level_6_pathname)) - length (rtrim (saved_level_6_entry))); level_6_entry = saved_level_6_entry; /* Make some minimal syntax checks on the L6 pathname. */ if multics_is_sender & (level_6_entry = "**" | index (substr (level_6_pathname, 2), "^") ^= 0) then call ERROR (error_table_$badpath, "Invalid L6 pathname: ^a.", level_6_pathname); /* Get temp segments for buffers for file IO and Level 6 IO. */ call get_temp_segments_ ("l6_tran_", temp_seg_ptrs, code); if code ^= 0 then call ERROR (code, "Trying to get temp segs for I/O buffers."); comm_buffer_len = sys_info$max_seg_size * 4; file_buffer_len = sys_info$max_seg_size * 4; /* Now do the real work. We are always the initiator and the Level 6 is the acceptor. */ if multics_is_sender then do; /* We are sending, and the file must exist. */ call Open_L6_Connection (); if ^l6_tran_info.flags.l6_attended then call Login_Dialogue (); call OK_Dialogue (); last_file = "0"b; /* Do the loop at least once. */ do while (^last_file); call Get_Next_Path (last_file); info.info_version = vfs_version_1; call vfile_status_ (multics_dir, multics_entry, addr (info), code); if code ^= 0 then call ERROR (code, "Trying to get vfile_status_ on: ^a, for sending.", multics_pathname) ; call Check_Multics_File (); call Open_Multics_File (); call Get_Saved_Attributes (); call File_Definition_Dialogue (); if l6_tran_info.flags.long then do; total_time = clock (); call ioa_$ioa_switch (out_iocbp, "Starting transfer of Multics file: ^a to Level 6 file: ^a.", multics_pathname, level_6_pathname); end; auto_transfer_input_args.version = transfer_input_args_version_1; auto_transfer_input_args.comm_iocbp = level_6_iocbp; auto_transfer_input_args.comm_buffer_ptr = comm_buffer_ptr; auto_transfer_input_args.comm_buffer_len = comm_buffer_len; auto_transfer_input_args.file_iocbp = multics_file_iocbp; auto_transfer_input_args.file_buffer_ptr = file_buffer_ptr; auto_transfer_input_args.file_buffer_len = file_buffer_len; auto_transfer_input_args.file_type = multics_file_type; auto_transfer_input_args.data_type = multics_data_type; auto_transfer_input_args.tu_size = SEND_TU_SIZE; auto_transfer_input_args.last_file = last_file; auto_transfer_input_args.prompt_read = (level_6_chars_read ^= 0); /* Set in File_Definition_Dialogue. */ auto_transfer_output_args.version = transfer_output_args_version_1; call l6_tran_send_file_ (addr (auto_transfer_input_args), addr (auto_transfer_output_args), P_error_message, P_code); if P_code ^= 0 then do; call Cleanup_Handler (); return; end; if l6_tran_info.flags.long then do; total_time = clock () - total_time; call ioa_$ioa_switch (out_iocbp, "Completed transfer of ^d records (^d bytes) in ^.3f seconds (^.3f bytes/sec).", auto_transfer_output_args.record_number + 1, auto_transfer_output_args.total_bytes, float (total_time) / 1e6, float (auto_transfer_output_args.total_bytes) / (float (total_time) / 1e6)); end; call iox_$close (multics_file_iocbp, code); call iox_$detach_iocb (multics_file_iocbp, code); call iox_$destroy_iocb (multics_file_iocbp, code); end; /* The last_file loop. */ /* "E" is not enough for the L6, send this too. */ level_6_chars_to_write = length (" 005&"); substr (comm_buffer, 1, level_6_chars_to_write) = " 005&"; call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); /* Ignore the code. */ end; /* We are sending, and the file must exist. */ else do; /* We are receiving, and the file may or may not exist. */ call Open_L6_Connection (); if ^l6_tran_info.flags.l6_attended then call Login_Dialogue (); call OK_Dialogue (); last_file = "0"b; /* Loop at least once. */ do while (^last_file); level_6_response_pathname = ""; /* The L6 may tell us differently. */ call File_Definition_Dialogue (); call Generate_Multics_Path (); info.info_version = vfs_version_1; call vfile_status_ (multics_dir, multics_entry, addr (info), code); if code = 0 then do; call Check_Multics_File (); call Verify_File_Attributes (); end; else call Create_Multics_File (); call Open_Multics_File (); call Set_Saved_Attributes (); if l6_tran_info.flags.long then do; total_time = clock (); call ioa_$ioa_switch (out_iocbp, "Starting transfer of Level 6 file: ^[^a^s^;^s^a^] to Multics file: ^a.", level_6_response_pathname ^= "", level_6_response_pathname, level_6_pathname, multics_pathname); end; auto_transfer_input_args.version = transfer_input_args_version_1; auto_transfer_input_args.comm_iocbp = level_6_iocbp; auto_transfer_input_args.comm_buffer_ptr = comm_buffer_ptr; auto_transfer_input_args.comm_buffer_len = comm_buffer_len; auto_transfer_input_args.file_iocbp = multics_file_iocbp; auto_transfer_input_args.file_buffer_ptr = file_buffer_ptr; auto_transfer_input_args.file_buffer_len = file_buffer_len; auto_transfer_input_args.file_type = multics_file_type; auto_transfer_input_args.data_type = multics_data_type; auto_transfer_input_args.tu_size = RECV_TU_SIZE; auto_transfer_output_args.version = transfer_output_args_version_1; call l6_tran_receive_file_ (addr (auto_transfer_input_args), addr (auto_transfer_output_args), P_error_message, P_code); if P_code ^= 0 then do; call Cleanup_Handler (); return; end; last_file = auto_transfer_output_args.last_file; if l6_tran_info.flags.long then do; total_time = clock () - total_time; call ioa_$ioa_switch (out_iocbp, "Completed transfer of ^d records (^d bytes) in ^.3f seconds (^.3f bytes/sec).", auto_transfer_output_args.record_number + 1, auto_transfer_output_args.total_bytes, float (total_time) / 1e6, float (auto_transfer_output_args.total_bytes) / (float (total_time) / 1e6)); end; call iox_$close (multics_file_iocbp, code); call iox_$detach_iocb (multics_file_iocbp, code); call iox_$destroy_iocb (multics_file_iocbp, code); end; /* The last_file loop. */ end; /* We are receiving, and the file may or may not exist. */ call Cleanup_Handler (); P_complete = "1"b; P_unhold = "1"b; P_error_message = ""; P_code = 0; return; %page; /******************************************************************************/ /* */ /* These entries are not yet implemented. We just want to document their */ /* calling sequences. */ /* */ /******************************************************************************/ cancel: entry (P_structure_ptr, P_structure_len, P_error_message, P_code); P_code = error_table_$unimplemented_version; return; %skip (5); modify: entry (P_in_iocbp, P_out_iocbp, P_caller_name, P_arg_list_ptr, P_first_arg, P_structure_ptr, P_structure_len, P_error_message, P_code); P_code = error_table_$unimplemented_version; return; %skip (5); list: entry (P_arg_list_ptr, P_first_arg, P_structure_ptr, P_structure_len, P_list_flag, P_output_lines, P_error_message, P_code); P_code = error_table_$unimplemented_version; return; %skip (5); info: entry (P_structure_ptr, P_structure_len, P_nasp_info_ptr, P_error_message, P_code); P_code = error_table_$unimplemented_version; return; Check_Multics_File: proc (); multics_file_type = info.type; if multics_file_type > BLOCKED_FILE_TYPE then call ERROR (error_table_$bad_file, "The Multics file must be unstructured, sequential, or blocked. File ^a is ^a.", multics_pathname, FILE_TYPE_TO_PNAME (multics_file_type)); if multics_file_type = BLOCKED_FILE_TYPE then do; multics_file_block_size = blk_info.max_rec_len; multics_file_size = blk_info.end_pos; end; else do; multics_file_block_size = 0; multics_file_size = 0; end; multics_file_l6_type = L6_S_FILE_TYPE; /* This is the default. */ /* Now find out if the file is special by looking for the suffix we put on it. */ status_area_ptr = get_user_free_area_ (); status_ptr = addr (auto_status_branch); call hcs_$status_ (multics_dir, multics_entry, CHASE, status_ptr, status_area_ptr, code); if code ^= 0 then call ERROR (code, "Trying to get status for: ^a.", multics_pathname); if status_branch.short.type = Directory then call ERROR (error_table_$dirseg, "^a.", multics_pathname); code = 1; /* Go through the loop at least once. */ do i = lbound (status_entry_names, 1) to hbound (status_entry_names, 1) while (code ^= 0); call match_star_name_ ((status_entry_names (i)), "**.*.l6*", code); if code = 0 then do; suffix = reverse (before (reverse (rtrim (status_entry_names (i))), ".")); do i = lbound (MULTICS_L6_FILE_SUFFIX, 1) to hbound (MULTICS_L6_FILE_SUFFIX, 1) while (suffix ^= MULTICS_L6_FILE_SUFFIX (i)); end; if i > hbound (MULTICS_L6_FILE_SUFFIX, 1) then code = 1; /* Keep looking. */ else multics_file_l6_type = i; end; end; if status_branch.nnames > 0 & status_branch.names_relp ^= "0"b then free status_entry_names in (status_area_ptr -> based_area); /* Cleanup after ourselves. */ if l6_tran_info.multics_data_type = BINARY & multics_file_type = UNSTRUCTURED_FILE_TYPE then call ERROR (error_table_$incompatible_file_attribute, "A binary file must be a sequential or blocked file: ^a.", multics_pathname); return; end Check_Multics_File; Create_Multics_File: proc (); multics_file_l6_type = level_6_file_type; if level_6_file_type = L6_S_FILE_TYPE & level_6_data_type = ASCII then multics_file_type = UNSTRUCTURED_FILE_TYPE; else if level_6_file_type = L6_S_FILE_TYPE then multics_file_type = SEQUENTIAL_FILE_TYPE; else multics_file_type = BLOCKED_FILE_TYPE; if multics_file_type = BLOCKED_FILE_TYPE then do; if level_6_max_record_size = 0 then multics_file_block_size = 256;/* Set default. */ else multics_file_block_size = level_6_max_record_size; end; else multics_file_block_size = 0; multics_file_size = 0; if MULTICS_L6_FILE_SUFFIX (multics_file_l6_type) ^= "" then do; call suffixed_name_$make (multics_entry, MULTICS_L6_FILE_SUFFIX (multics_file_l6_type), multics_entry, code); if code ^= 0 then call ERROR (code, "Trying to add the suffix ""^a"" to ^a", MULTICS_L6_FILE_SUFFIX (multics_file_l6_type), multics_pathname); multics_pathname = pathname_ (multics_dir, multics_entry); end; call hcs_$append_branch (multics_dir, multics_entry, RW_ACCESS_BIN, code); if code ^= 0 then call ERROR (code, "Trying to create: ^a.", multics_pathname); return; end Create_Multics_File; File_Definition_Dialogue: proc (); dcl acceptor_file_count pic "99"; dcl chars_read fixed bin (21); dcl ci_size pic "99999"; dcl char_position fixed bin; dcl data_type char (1); dcl file_access char (1); dcl file_name_len pic "99"; dcl file_size pic "99999"; dcl file_type char (1); dcl fixed_response_len fixed bin (21); dcl indicator char (1); dcl initiator_file_count pic "99"; dcl key_length pic "999"; dcl key_offset pic "9999"; dcl key_type char (1); dcl 1 l6_response unaligned based (comm_buffer_ptr), 2 header, 3 first_char char (1), /* Should be "8". */ 3 response_len pic "999", 3 ack_indicator char (1), /* "$"--yes, "&"--no. */ 2 rest_of_response char (rest_of_response_len); dcl l6_response_path_len pic "99"; dcl output_message_len pic "999"; dcl percent_fill pic "99"; dcl record_size pic "9999"; dcl rest_of_response_len fixed bin; dcl starting_record pic "99999"; if multics_is_sender then do; /* We must describe the file to the Level 6. */ file_name_len = length (rtrim (level_6_pathname)) + 1; /* The L6 requires a trailing space in the name. */ record_size = multics_file_block_size; starting_record = 0; file_size = multics_file_size; initiator_file_count = 1; acceptor_file_count = 1; call ioa_$rsnpnnl (" 000 O!^2a^a ^[#^a^;^s#P^aQ^a^[R^a^;^s^]S^a^[Z^a^;^s^][^a\^a^]", comm_buffer, level_6_chars_to_write, file_name_len, rtrim (level_6_pathname), saved_attributes ^= "", saved_attributes, L6_FILE_TYPE (multics_file_l6_type), L6_DATA_TYPE (l6_tran_info.multics_data_type), multics_file_block_size > 0, record_size, starting_record, multics_file_size > 0, file_size, initiator_file_count, acceptor_file_count); output_message_len = level_6_chars_to_write; /* Set the message length. */ substr (comm_buffer, 2, 3) = output_message_len; call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to send the output file definition to the Level 6."); end; /* We must describe the file to the Level 6. */ else do; /* The Level 6 will tell us about the file. */ file_name_len = length (rtrim (level_6_pathname)) + 1; /* The L6 requires a trailing space in the name. */ call ioa_$rsnpnnl (" 000 I!^2a^a ", comm_buffer, level_6_chars_to_write, file_name_len, rtrim (level_6_pathname)); output_message_len = level_6_chars_to_write; /* Set the message length. */ substr (comm_buffer, 2, 3) = output_message_len; call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to send the input file definition to the Level 6."); end; /* The Level 6 will tell us about the file. */ /* Get the Level 6 response to our request. This involves a loop to get everything he says he sent. */ call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read the output file definition ack from the Level 6."); fixed_response_len = l6_response.response_len; rest_of_response_len = fixed_response_len - length (string (l6_response.header)); do chars_read = level_6_chars_read repeat chars_read + level_6_chars_read while (chars_read < fixed_response_len); call l6_tran_util_$get_chars (level_6_iocbp, add_char_offset_ (comm_buffer_ptr, chars_read), comm_buffer_len - chars_read, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read the output file definition ack from the Level 6."); end; /*****************************************************************************/ /* */ /* Do the following strange thing in case the first prompt sent by the L6 */ /* was combined with the file definition response when we called */ /* get_chars. The variable level_6_chars_read is declared in our caller, */ /* so set it to be any extra characters after the response. We will */ /* assume that this is the prompt and will not try to get the prompt in */ /* l6_tran_send_file_. We have to do a similar thing in */ /* l6_tran_overseer_, but there we use a write_status to guarantee that */ /* our response is not combined with our prompt. This stuff is all a */ /* kludge because there is no way to use the "more_data" bit in an X.25 */ /* packet on Multics. */ /* */ /*****************************************************************************/ level_6_chars_read = level_6_chars_read - fixed_response_len; /*****************************************************************************/ if l6_response.ack_indicator ^= "$" then do; if l6_response.rest_of_response = "'82FF" then call ERROR (0b, "The last file has been received."); /* Not really an error. */ else call ERROR (error_table_$fatal_error, "The Level 6 rejected the file transfer. From L6: ^a.", l6_response.rest_of_response); end; /* Set default level 6 file attributes, and then get the real ones, if any. */ level_6_data_type = ASCII; level_6_file_type = L6_S_FILE_TYPE; level_6_max_record_size = 0; if l6_response.rest_of_response ^= "" then do; /* Process the file attributes. */ char_position = 1; do while (char_position <= length (l6_response.rest_of_response)); /* Loop through the file attributes. */ indicator = substr (l6_response.rest_of_response, char_position, length (indicator)); char_position = char_position + length (indicator); if indicator = "!" then do; /* He is sending us his pathname. */ string (l6_response_path_len) = substr (l6_response.rest_of_response, char_position, length (l6_response_path_len)); char_position = char_position + length (l6_response_path_len); level_6_response_pathname = substr (l6_response.rest_of_response, char_position, l6_response_path_len); char_position = char_position + l6_response_path_len; end; /* He is sending us his pathname. */ else if indicator = "#" then saved_attributes = substr (l6_response.rest_of_response, char_position); else if indicator = "P" then do; /* File type */ file_type = substr (l6_response.rest_of_response, char_position, length (file_type)); char_position = char_position + length (file_type); level_6_file_type = index (string (L6_FILE_TYPE), file_type); if level_6_file_type = 0 then call ERROR (error_table_$bad_file, "The Level 6 file type: ""^a"", is not supported.", file_type); end; else if indicator = "Q" then do; /* Data type */ data_type = substr (l6_response.rest_of_response, char_position, length (data_type)); char_position = char_position + length (data_type); level_6_data_type = index (string (L6_DATA_TYPE), data_type); if level_6_data_type = 0 then call ERROR (error_table_$bad_file, "The Level 6 data type: ""^a"", is not supported.", data_type); end; else if indicator = "R" then do; /* Record size */ string (record_size) = substr (l6_response.rest_of_response, char_position, length (record_size)); char_position = char_position + length (record_size); level_6_max_record_size = record_size; end; else if indicator = "S" then do; /* Starting record */ string (starting_record) = substr (l6_response.rest_of_response, char_position, length (starting_record)); char_position = char_position + length (starting_record); end; else if indicator = "T" then do; /* File access code */ file_access = substr (l6_response.rest_of_response, char_position, length (file_access)); char_position = char_position + length (file_access); end; else if indicator = "U" then do; /* Key length */ string (key_length) = substr (l6_response.rest_of_response, char_position, length (key_length)); char_position = char_position + length (key_length); end; else if indicator = "V" then do; /* Key offset */ string (key_offset) = substr (l6_response.rest_of_response, char_position, length (key_offset)); char_position = char_position + length (key_offset); end; else if indicator = "W" then do; /* Percent fill */ string (percent_fill) = substr (l6_response.rest_of_response, char_position, length (percent_fill)); char_position = char_position + length (percent_fill); end; else if indicator = "X" then do; /* Key type */ key_type = substr (l6_response.rest_of_response, char_position, length (key_type)); char_position = char_position + length (key_type); end; else if indicator = "Y" then do; /* CI size */ string (ci_size) = substr (l6_response.rest_of_response, char_position, length (ci_size)); char_position = char_position + length (ci_size); end; else if indicator = "Z" then do; /* File size (in CI units) */ string (file_size) = substr (l6_response.rest_of_response, char_position, length (file_size)); char_position = char_position + length (file_size); end; else if indicator = "[" then do; /* Initiator's file count */ string (initiator_file_count) = substr (l6_response.rest_of_response, char_position, length (initiator_file_count)); char_position = char_position + length (initiator_file_count); end; else if indicator = "\" then do; /* Acceptor's file count */ string (acceptor_file_count) = substr (l6_response.rest_of_response, char_position, length (acceptor_file_count)) ; char_position = char_position + length (acceptor_file_count); end; else ; /* Not recognized, skip it */ end; /* Loop through the attributes. */ end; /* Process the file attributes. */ return; end File_Definition_Dialogue; Generate_Multics_Path: proc (); dcl code fixed bin (35); dcl l6_entryname char (32); if level_6_response_pathname ^= "" then do; /* We must generate the Multics name. */ l6_entryname = reverse (before (reverse (level_6_response_pathname), ">")); call get_equal_name_ (l6_entryname, saved_multics_entry, multics_entry, code); if code ^= 0 then call ERROR (code, "Trying to do equal name processing on: ^a, matching: ^a.", saved_multics_entry, l6_entryname); multics_pathname = pathname_ (multics_dir, multics_entry); end; /* We must generate the Multics name. */ return; end Generate_Multics_Path; Get_Next_Path: proc (P_last_file); dcl P_last_file bit (1) parameter; dcl code fixed bin (35); call check_star_name_$entry (saved_multics_entry, code); if code = 0 then P_last_file = "1"b; /* Not a star name, nothing to do. */ else if code = error_table_$badstar then call ERROR (code, "Multics file name: ^a.", saved_multics_entry); else do; /* We have a star name. */ if ^star_names_generated then do; /* Get the star list once. */ star_area_ptr = get_user_free_area_ (); call hcs_$star_ (multics_dir, saved_multics_entry, star_ALL_ENTRIES, star_area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then call ERROR (code, "Trying to match starname ^a in directory ^a.", saved_multics_entry, multics_dir); /* Set the index to the first non-directory entry. */ do star_entries_index = 1 to hbound (star_entries, 1) while (star_entries (star_entries_index).type = star_DIRECTORY); end; if star_entries_index > hbound (star_entries, 1) then call ERROR (error_table_$dirseg, "Only directories match ^a.", multics_pathname); star_names_generated = "1"b; end; /* Get the star list once. */ /* Just use the first matching name on an entry. */ multics_entry = star_names (star_entries (star_entries_index).nindex); multics_pathname = pathname_ (multics_dir, multics_entry); /* Now update the star_entries_index and set P_last_file. */ do star_entries_index = star_entries_index + 1 to hbound (star_entries, 1) while (star_entries (star_entries_index).type = star_DIRECTORY); end; if star_entries_index > hbound (star_entries, 1) then P_last_file = "1"b; else P_last_file = "0"b; end; /* We have a star name. */ /* Now generate the L6 pathname. */ call get_equal_name_ (multics_entry, saved_level_6_entry, level_6_entry, code); if code ^= 0 then call ERROR (code, "Trying to do equalname matching on L6 name: ^a, against Multics name: ^a.", saved_level_6_entry, multics_entry); level_6_pathname = rtrim (level_6_dir) || level_6_entry; return; end Get_Next_Path; Get_Saved_Attributes: proc (); if multics_file_l6_type ^= L6_S_FILE_TYPE then do; call iox_$read_record (multics_file_iocbp, file_buffer_ptr, file_buffer_len, multics_chars_read, code) ; if code ^= 0 then call ERROR (code, "Trying to get the file attributes from the multics file: ^a.", multics_pathname); saved_attributes = substr (file_buffer, 1, multics_chars_read); end; else saved_attributes = ""; return; end Get_Saved_Attributes; Login_Dialogue: proc (); dcl chars_read fixed bin (21); dcl greeting_message_found bit (1); call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read the Level 6 greeting message."); greeting_message_found = "0"b; do chars_read = level_6_chars_read repeat chars_read + level_6_chars_read while (^greeting_message_found); /* Discard extraneous lines. */ if index (substr (comm_buffer, 1, chars_read), "LOAD = ") ^= 0 | index (substr (comm_buffer, 1, chars_read), "Load = ") ^= 0 | index (substr (comm_buffer, 1, chars_read), "LOGIN") ^= 0 then do; /* We have found a greeting message. */ greeting_message_found = "1"b; if debug_flag then call ioa_$rsnpnnl ("l ^a -bf -create -nw -pf -nosave -po l6_tran_overseer_^/", comm_buffer, level_6_chars_to_write, l6_tran_info.user_name); else call ioa_$rsnpnnl ("L ^a -PO TRANX -ARG ^[R^;S^]DAU^a", comm_buffer, level_6_chars_to_write, l6_tran_info.user_name, multics_is_sender, CR); call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to send the login line to the Level 6."); /* Read characters until we find "HI" or "PASSWORD" as a substring, then assume we got everything since there is no delimiter. */ call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read ""HI"" or ""PASSWORD"" after login."); do chars_read = level_6_chars_read repeat chars_read + level_6_chars_read while ((index (substr (comm_buffer, 1, chars_read), "HI") = 0) & (index (substr (comm_buffer, 1, chars_read), "PASSWORD") = 0)); call l6_tran_util_$get_chars (level_6_iocbp, add_char_offset_ (comm_buffer_ptr, chars_read), comm_buffer_len - chars_read, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read ""HI"" or ""PASSWORD"" after login."); end; if index (substr (comm_buffer, 1, chars_read), "PASSWORD") ^= 0 then do; /* L6 wants a password. */ if l6_tran_info.password = "" then do; /* Get the password from the user. */ call read_password_$switch (out_iocbp, in_iocbp, "Level 6 has requested password:", l6_tran_info.password, code); /* Forget the code, we won't use it anyway. */ end; /* Get the password from the user. */ level_6_chars_to_write = length (rtrim (l6_tran_info.password)); if debug_flag then substr (comm_buffer, 1, level_6_chars_to_write) = rtrim (l6_tran_info.password) || " "; else substr (comm_buffer, 1, level_6_chars_to_write) = rtrim (l6_tran_info.password); l6_tran_info.password = ""; /* Erase the password now. */ call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to send the password to the Level 6."); /* Read characters until we find "HI" as a substring, then assume we got everything since there is no delimiter. */ call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read ""HI"" after login."); do chars_read = level_6_chars_read repeat chars_read + level_6_chars_read while (index (substr (comm_buffer, 1, chars_read), "HI") = 0); call l6_tran_util_$get_chars (level_6_iocbp, add_char_offset_ (comm_buffer_ptr, chars_read), comm_buffer_len - chars_read, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read ""HI"" after login."); end; end; /* L6 wants a password. */ else ; /* We found the "HI", and that's it. */ end; /* We have found a greeting message. */ else do; /* Get some more characters and look again. */ greeting_message_found = "0"b; call l6_tran_util_$get_chars (level_6_iocbp, add_char_offset_ (comm_buffer_ptr, chars_read), comm_buffer_len - chars_read, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read the Level 6 greeting message."); end; end; /* Discard extraneous lines. */ return; end Login_Dialogue; OK_Dialogue: proc (); level_6_chars_to_write = length ("OK?"); substr (comm_buffer, 1, level_6_chars_to_write) = "OK?"; call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to send ""OK?"" to the Level 6."); call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read ""OK"" from the Level 6."); if substr (comm_buffer, 1, level_6_chars_read) ^= "OK" then ; /* Something wrong, but keep going anyway. */ return; end OK_Dialogue; Open_L6_Connection: proc (); call ioa_$rsnnl ("tty_ ^a -destination ^a", level_6_attach_desc, ignored_len, l6_tran_info.net_name, l6_tran_info.net_address); call iox_$attach_name (l6_tran_info.net_name, level_6_iocbp, (level_6_attach_desc), null (), code); if code ^= 0 & code ^= error_table_$not_detached then call ERROR (code, "Trying to attach the Level 6 on channel: ^a.", l6_tran_info.net_name); call iox_$open (level_6_iocbp, Stream_input_output, "0"b, code); if code ^= 0 & code ^= error_table_$not_closed then call ERROR (code, "Trying to open the Level 6 channel: ^a.", l6_tran_info.net_name); call iox_$modes (level_6_iocbp, "8bit,rawi,rawo", "", code); if code ^= 0 then call ERROR (code, "Trying to set modes on switch: ^a to ""8bit,rawi,rawo"".", l6_tran_info.net_name); return; end Open_L6_Connection; Open_Multics_File: proc (); call ioa_$rsnnl ("^[record_stream_ -target ^]vfile_ ^a^[ -blocked ^d^;^s^]", multics_file_attach_desc, ignored_len, multics_file_type = UNSTRUCTURED_FILE_TYPE, multics_pathname, multics_file_type = BLOCKED_FILE_TYPE, multics_file_block_size); call iox_$attach_name (multics_entry, multics_file_iocbp, (multics_file_attach_desc), null (), code); if code ^= 0 & code ^= error_table_$not_detached then call ERROR (code, "Trying to attach file: ^a through switch: ^a.", multics_pathname, multics_entry); if multics_is_sender then multics_file_open_mode = Sequential_input; else multics_file_open_mode = Sequential_output; call iox_$open (multics_file_iocbp, multics_file_open_mode, "0"b, code); if code ^= 0 & code ^= error_table_$not_closed then call ERROR (code, "Trying to open file: ^a through switch: ^a.", multics_pathname, multics_entry); return; end Open_Multics_File; Process_File_Name: proc (); dcl code fixed bin (35); dcl sender_file_flag bit (1); if l6_tran_info.sender_info.pathname = "" then do; /* From file first. */ l6_tran_info.sender_info.pathname = arg; sender_file_flag = "1"b; end; else do; /* To file second. */ l6_tran_info.receiver_info.pathname = arg; sender_file_flag = "0"b; end; /* Now peek ahead in the arg list to see if there is a host specified for this file. */ call cu_$arg_ptr_rel (arg_idx + 1, arg_ptr, arg_len, code, arg_list_ptr); if code = 0 then do; /* There is a next arg. */ if arg = "-at" then do; /* Pick up the host name. */ arg_idx = arg_idx + 2; /* Set to host arg number. */ call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then call ERROR (code, "Trying to get the host name after the ""-at"" argument."); if sender_file_flag then l6_tran_info.sender_info.host_name = arg; else l6_tran_info.receiver_info.host_name = arg; end; /* Pick up the host name. */ end; /* There is a next arg. */ return; end Process_File_Name; Set_Saved_Attributes: proc (); if multics_file_l6_type ^= L6_S_FILE_TYPE then do; multics_chars_to_write = length (saved_attributes); substr (file_buffer, 1, multics_chars_to_write) = saved_attributes; call iox_$write_record (multics_file_iocbp, file_buffer_ptr, multics_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to save the file attributes in: ^a.", multics_pathname); end; return; end Set_Saved_Attributes; Verify_File_Attributes: proc (); if multics_file_l6_type ^= level_6_file_type then call ERROR (error_table_$bad_file, "The Level 6 file type does not match the existing Multics file type. (M = ^a, L6 = ^a).", L6_FILE_TYPE (multics_file_l6_type), L6_FILE_TYPE (level_6_file_type)); if multics_file_type = BLOCKED_FILE_TYPE & multics_file_block_size < level_6_max_record_size then call ERROR (error_table_$bad_file, "The Multics file block size is less than the Level 6 record size. (M = ^d, L6 = ^d).", multics_file_block_size, level_6_max_record_size); if multics_file_type = UNSTRUCTURED_FILE_TYPE & ^(level_6_file_type = L6_S_FILE_TYPE & level_6_data_type = ASCII) then call ERROR (error_table_$bad_file, "Only a sequential ascii Level 6 file may be transferred to an unstructured Multics file."); return; end Verify_File_Attributes; /*****************************************************************************/ /* */ /* PROCEDURE: ERROR */ /* */ /* This subroutine expects arguments as follows: */ /* */ /* call ERROR (code, ioa_control_string, ioa_arguments, ...) */ /* */ /* where: code is fixed bin (35), and ioa_control_string and ioa_arguments */ /* are optional character strings as defined for ioa_. */ /* */ /* Some global variables are used: */ /* */ /* Cleanup_Handler (a procedure that does cleanup) */ /* */ /* For commands: */ /* report_error (an entry variable set to com_err_ or active_fnc_err_)*/ /* command_name (the character string name of the command) */ /* return_arg_ptr (used to return "false" for active functions) */ /* */ /* For subroutines: */ /* depends on the error reporting strategy chosen. */ /* */ /* At completion a non-local goto is done to the label RETURN. */ /* */ /* Declarations are expected for: */ /* */ /* cu_$arg_list_ptr */ /* cu_$arg_ptr */ /* cu_$arg_count */ /* error_table_$fatal_error */ /* ioa_$general_rs */ /* */ /*****************************************************************************/ ERROR: proc () options (variable, non_quick); dcl arg_list_ptr ptr; dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl based_code fixed bin (35) based; dcl caller_code fixed bin (35); dcl code fixed bin (35); dcl err_msg char (256); dcl err_msg_len fixed bin (21); dcl nargs fixed bin; call cu_$arg_count (nargs, code); /* IGNORE CODE */ if nargs >= 1 then do; /* We were called correctly. */ arg_ptr = null (); /* Set this so we know if cu_$arg_ptr worked. */ call cu_$arg_ptr (1, arg_ptr, arg_len, code); if arg_ptr ^= null () then caller_code = arg_ptr -> based_code; /* The normal case. */ else caller_code = error_table_$fatal_error; /* Some problem with our arg list. */ if nargs > 1 then do; /* There is a message. */ call cu_$arg_list_ptr (arg_list_ptr); call ioa_$general_rs (arg_list_ptr, 2, 3, err_msg, err_msg_len, "1"b, "0"b); end; else do; /* No message. */ err_msg = ""; err_msg_len = 0; end; end; /* We were called correctly. */ else do; /* We were called with no arguments. */ caller_code = error_table_$fatal_error; /* The best we can do. */ err_msg = ""; err_msg_len = 0; end; /* We were called with no arguments. */ /* The following lines must be modified depending on the error reporting strategy used. */ if level_6_iocbp ^= null () & comm_buffer_ptr ^= null () then do; /* Tell the Level 6. */ dcl pic_err_msg_len pic "99"; pic_err_msg_len = min (99, err_msg_len); call ioa_$rsnpnnl ("CU^a^aR", comm_buffer, level_6_chars_to_write, pic_err_msg_len, substr (err_msg, 1, pic_err_msg_len)); call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); end; P_error_message = substr (err_msg, 1, err_msg_len); P_code = caller_code; /* Clean up and do a non-local goto back to the outermost block. */ call Cleanup_Handler (); goto RETURN; end ERROR; Parser_Cleanup: proc (); if l6tip ^= null () then free l6_tran_info in (based_area); return; end Parser_Cleanup; Execute_Cleanup: proc (); dcl code fixed bin (35); if status_area_ptr ^= null () & status_ptr ^= null () then do; if status_branch.nnames > 1 & status_branch.names_relp ^= "0"b then free status_entry_names in (status_area_ptr -> based_area); end; if star_area_ptr ^= null () then do; /* Order is important here. */ if star_names_ptr ^= null () & star_entry_ptr ^= null () then free star_names in (star_area_ptr -> based_area); if star_entry_ptr ^= null () then free star_entries in (star_area_ptr -> based_area); end; if multics_file_iocbp ^= null () then do; call iox_$close (multics_file_iocbp, code); call iox_$detach_iocb (multics_file_iocbp, code); call iox_$destroy_iocb (multics_file_iocbp, code); end; if level_6_iocbp ^= null () then do; call iox_$close (level_6_iocbp, code); call iox_$detach_iocb (level_6_iocbp, code); call iox_$destroy_iocb (level_6_iocbp, code); end; if file_buffer_ptr ^= null () | comm_buffer_ptr ^= null () then call release_temp_segments_ ("l6_tran_", temp_seg_ptrs, code); return; end Execute_Cleanup; debug_on: entry (); debug_flag = "1"b; return; debug_off: entry (); debug_flag = "0"b; return; end l6_tran_;  l6_tran_overseer_.pl1 07/13/88 1242.3r w 07/13/88 0935.4 331515 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /*****************************************************************************/ /* */ /* DESCRIPTION: */ /* */ /* This subroutine is the server for file transfer to or from the */ /* Level 6 over an X.25 connection. It is implemented as a process */ /* overseer so that the answering service can do all of the hard work of */ /* making the connection. This server corresponds to the NASP, l6_tran_, */ /* which does the Multics initiated side of the file transfer. */ /* */ /* */ /* JOURNALIZATION: */ /* */ /* 1) Written 5/82 by R.J.C Kissel */ /* 2) Modified 7/83 by R.J.C. Kissel to fix an error message sent to the L6*/ /* 3) Modified 7/83 by R.J.C. Kissel to fix an error in terminating the */ /* process. */ /* */ /*****************************************************************************/ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */ l6_tran_overseer_: proc (P_pit_ptr, P_call_listener, P_with_command_line); /* Parameters */ dcl P_pit_ptr ptr parameter; dcl P_call_listener bit (1) aligned parameter; dcl P_with_command_line char (*) varying parameter; /* Automatic */ dcl P_error_message char (256) varying; /* Needed by ERROR, but never used. */ dcl P_code fixed bin (35); /* Needed by ERROR, but never used. */ dcl 1 auto_status_branch aligned like status_branch; dcl 1 auto_transfer_input_args aligned like transfer_input_args; dcl 1 auto_transfer_output_args aligned like transfer_output_args; dcl based_area area (sys_info$max_seg_size) based (area_ptr); dcl area_ptr ptr; dcl code fixed bin (35); dcl comm_buffer char (comm_buffer_len) based (comm_buffer_ptr); dcl comm_buffer_len fixed bin (21); dcl comm_buffer_ptr ptr defined (temp_seg_ptrs (1)); dcl file_buffer char (file_buffer_len) based (file_buffer_ptr); dcl file_buffer_len fixed bin (21); dcl file_buffer_ptr ptr defined (temp_seg_ptrs (2)); dcl i fixed bin; dcl ignored_len fixed bin (21); /* Used in calls to ioa_$rsnnl. */ dcl last_file bit (1); dcl level_6_chars_read fixed bin (21); dcl level_6_chars_to_write fixed bin (21); dcl level_6_data_type fixed bin; dcl level_6_dir char (168); dcl level_6_entry char (32); dcl level_6_file_type fixed bin; dcl level_6_iocbp ptr; dcl level_6_max_record_size fixed bin; dcl level_6_pathname char (168); dcl 1 logout_string aligned, /* information about logouts */ 2 version fixed bin, /* this is version 0 */ 2 hold bit (1) unaligned, /* don't hangup line */ 2 brief bit (1) unaligned, /* don't print logout message */ 2 pad bit (34) unaligned; /* must be zero */ dcl multics_chars_read fixed bin (21); dcl multics_chars_to_write fixed bin (21); dcl multics_data_type fixed bin; dcl multics_dir char (168); dcl multics_entry char (32); dcl multics_file_attach_desc char (256) varying; dcl multics_file_block_size fixed bin (21); dcl multics_file_exists bit (1); dcl multics_file_iocbp ptr; dcl multics_file_l6_type fixed bin; dcl multics_file_type fixed bin; dcl multics_file_open_mode fixed bin; dcl multics_file_size fixed bin (34); dcl multics_is_sender bit (1); dcl multics_pathname char (168); dcl saved_level_6_entry char (32); dcl saved_multics_entry char (32); dcl star_area_ptr ptr; dcl star_entries_index fixed bin; dcl star_names_generated bit (1); dcl suffix char (32); dcl temp_seg_ptrs (2) ptr; dcl term_structure_ptr ptr; dcl 1 info aligned like indx_info;/* Use the biggest structure. */ /* Internal Constants */ dcl REL_SECONDS bit (2) internal static options (constant) init ("11"b); %include l6_tran_constants; /* Internal Static */ dcl debug_flag bit (1) internal static init ("0"b); /* External Constants */ dcl error_table_$bad_file fixed bin (35) ext static; dcl error_table_$badstar fixed bin (35) ext static; dcl error_table_$dirseg fixed bin (35) ext static; dcl error_table_$fatal_error fixed bin (35) ext static; dcl error_table_$not_closed fixed bin (35) ext static; dcl error_table_$not_detached fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (19) ext static; /* External Entries */ dcl add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35)); dcl get_user_free_area_ entry () returns (ptr); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl hcs_$append_branch entry (char (*), char (*), fixed bin (5), fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned); dcl ioa_$rsnnl entry () options (variable); dcl ioa_$rsnpnnl entry options (variable); dcl l6_tran_util_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl l6_tran_util_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl l6_tran_receive_file_ entry (ptr, ptr, char (*) var, fixed bin (35)); dcl l6_tran_send_file_ entry (ptr, ptr, char (*) var, fixed bin (35)); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl suffixed_name_$make entry (char (*), char (*), char (32), fixed bin (35)); dcl terminate_process_ entry (char (*), ptr); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl vfile_status_ entry (char (*), char (*), ptr, fixed bin (35)); /* Builtin Functions and Conditions */ dcl addr builtin; dcl before builtin; dcl hbound builtin; dcl index builtin; dcl lbound builtin; dcl length builtin; dcl min builtin; dcl null builtin; dcl pointer builtin; dcl reverse builtin; dcl rtrim builtin; dcl string builtin; dcl substr builtin; dcl sum builtin; dcl any_other condition; dcl finish condition; /* Include Files */ %include l6_tran_transfer_args; %include star_structures; /* vfs_info.incl.pl1 */ %include vfs_info; %include access_mode_values; %include status_structures; %include iox_entries; %include iox_modes; %include pit; %include user_attributes; pit_ptr = P_pit_ptr; P_call_listener = "0"b; /* We will never return anyway. */ P_with_command_line = ""; /* Set things up for for an error, in which case we will tell the Level 6 and logout. */ status_area_ptr = null (); status_ptr = null (); auto_status_branch.nnames = 0; auto_status_branch.names_relp = "0"b; multics_file_iocbp = null (); level_6_iocbp = iox_$user_io; file_buffer_ptr = null (); comm_buffer_ptr = null (); star_names_generated = "0"b; star_entry_ptr = null (); star_names_ptr = null (); star_area_ptr = null (); star_entry_count = 0; star_entries_index = 0; on finish ; /* Do nothing. */ on any_other call ERROR (error_table_$fatal_error, "The file transfer has abnormally terminated."); /* Get temp segments for buffers for file IO and Level 6 IO. */ call iox_$modes (level_6_iocbp, "8bit,rawi,rawo", "", code); if code ^= 0 then call ERROR (code, "Trying to set modes for Level 6 comm."); call get_temp_segments_ ("l6_tran_", temp_seg_ptrs, code); if code ^= 0 then call ERROR (code, "Trying to get a temp segs."); comm_buffer_len = sys_info$max_seg_size * 4; file_buffer_len = sys_info$max_seg_size * 4; /* Now do the real work. We are always the acceptor and the Level 6 is the initiator. */ level_6_chars_to_write = length ("HI"); /* First tell him we are here. */ substr (comm_buffer, 1, level_6_chars_to_write) = "HI"; call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); if code ^= 0 then call ERROR (code, "Could not send ""HI""."); call OK_Dialogue (); /* Loop here to handle possible star name transfers. */ last_file = "0"b; /* Loop at least once. */ do while (^last_file); call File_Definition_Dialogue (); auto_transfer_input_args.version = transfer_input_args_version_1; auto_transfer_input_args.comm_iocbp = level_6_iocbp; auto_transfer_input_args.comm_buffer_ptr = comm_buffer_ptr; auto_transfer_input_args.comm_buffer_len = comm_buffer_len; auto_transfer_input_args.file_iocbp = multics_file_iocbp; auto_transfer_input_args.file_buffer_ptr = file_buffer_ptr; auto_transfer_input_args.file_buffer_len = file_buffer_len; auto_transfer_input_args.file_type = multics_file_type; auto_transfer_input_args.data_type = multics_data_type; auto_transfer_output_args.version = transfer_output_args_version_1; if multics_is_sender then do; auto_transfer_input_args.tu_size = SEND_TU_SIZE; auto_transfer_input_args.last_file = last_file; /* Set by File_Definition_Dialogue. */ call l6_tran_send_file_ (addr (auto_transfer_input_args), addr (auto_transfer_output_args), P_error_message, P_code); end; else do; auto_transfer_input_args.tu_size = RECV_TU_SIZE; call l6_tran_receive_file_ (addr (auto_transfer_input_args), addr (auto_transfer_output_args), P_error_message, P_code); last_file = auto_transfer_output_args.last_file; end; /* We are finished with the file, get rid of it. */ call iox_$close (multics_file_iocbp, code); call iox_$detach_iocb (multics_file_iocbp, code); call iox_$destroy_iocb (multics_file_iocbp, code); end; /* Loop while ^last_file. */ if multics_is_sender then do; /* "E" is not enough, so engage in a final dialogue. */ call File_Definition_Dialogue (); /* Last_file = "1"b here. */ end; /*****************************************************************************/ /* */ /* We are done, so terminate the process. Do it in this gross way so no */ /* "hangup" message is sent. Also, wait a minute before we terminate so */ /* we avoid confusing the Level 6 if he wanted to do the termination. (If */ /* he terminates, this will also kill us.) */ /* */ /*****************************************************************************/ LAST_FILE_RETURN: /* Come here from File_Definition_Dialogue since "E" is not set. */ call Cleanup_Handler (); RETURN: call timer_manager_$sleep (60, REL_SECONDS); /* Wait in case the L6 wants to terminate. */ /* How to logout cleanly, if we ever want to. logout_string.version = 0; logout_string.hold = "0"b; logout_string.brief = "1"b; logout_string.pad = "0"b; term_structure_ptr = addr (logout_string); call terminate_process_ ("logout", term_structure_ptr); */ call iox_$control (iox_$user_io, "hangup", null (), code); call timer_manager_$sleep (60, REL_SECONDS); /* Wait for the "hangup" to take. */ return; /* We should never get here. */ File_Definition_Dialogue: proc (); dcl acceptor_file_count pic "99"; dcl chars_read fixed bin (21); dcl ci_size pic "99999"; dcl char_position fixed bin; dcl data_type char (1); dcl file_access char (1); dcl file_size pic "99999"; dcl file_type char (1); dcl fixed_definition_len fixed bin (21); dcl indicator char (1); dcl initiator_file_count pic "99"; dcl key_length pic "999"; dcl key_offset pic "9999"; dcl key_type char (1); dcl l6_path_len pic "99"; dcl 1 l6_file_definition unaligned based (comm_buffer_ptr), 2 header, 3 first_char char (1) unaligned, /* Should be " ". */ 3 definition_len pic "999" unaligned, 3 another_char char (1) unaligned, /* Should be " ". */ 3 direction char (1) unaligned, /* Should be "I" or "O". */ 3 file_name_indicator char (1) unaligned, /* Should be "!". */ 3 file_name_len pic "99" unaligned, 3 file_name char (0 refer (l6_file_definition.file_name_len)) unaligned, 2 rest_of_definition char (rest_of_definition_len) unaligned; dcl output_message_len pic "999"; dcl percent_fill pic "99"; dcl record_size pic "9999"; dcl rest_of_definition_len fixed bin; dcl starting_record pic "99999"; dcl saved_attributes char (256) varying; /* Get the Level 6 file definition record. This involves a loop to get everything he says he sent. */ call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read the file definition from the Level 6."); fixed_definition_len = l6_file_definition.definition_len; rest_of_definition_len = fixed_definition_len - length (string (l6_file_definition.header)); do chars_read = level_6_chars_read repeat chars_read + level_6_chars_read while (chars_read < fixed_definition_len); call l6_tran_util_$get_chars (level_6_iocbp, add_char_offset_ (comm_buffer_ptr, chars_read), comm_buffer_len - chars_read, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read the file definition from the Level 6."); end; /* Special no file message, instead of "E" on last file, when Multics is receiving. */ if l6_file_definition.another_char = "&" then goto LAST_FILE_RETURN; /* Special return for last file dialogue when Multics is sending. */ if last_file then do; level_6_chars_to_write = length ("8010&'82FF"); substr (comm_buffer, 1, level_6_chars_to_write) = "8010&'82FF"; call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); /* Ignore the code. */ return; end; if l6_file_definition.direction = "I" then multics_is_sender = "1"b; else multics_is_sender = "0"b; multics_pathname = l6_file_definition.file_name; call expand_pathname_ (multics_pathname, multics_dir, saved_multics_entry, code); if code ^= 0 then call ERROR (code, "Trying to expand multics pathname: ^a.", multics_pathname); multics_pathname = pathname_ (multics_dir, saved_multics_entry); /* Turn into absolute pathname. */ multics_entry = saved_multics_entry; level_6_dir = ""; /* We don't know. */ saved_level_6_entry = "=="; /* Tell him names that match ours. */ /* Set default Level 6 file attributes, and then get the real ones, if any. */ level_6_data_type = ASCII; level_6_file_type = L6_S_FILE_TYPE; level_6_max_record_size = 0; if l6_file_definition.rest_of_definition ^= "" then do; /* Process the file attributes. */ char_position = 1; indicator = substr (l6_file_definition.rest_of_definition, char_position, length (indicator)); if indicator = "#" then do; char_position = char_position + length (indicator); saved_attributes = substr (l6_file_definition.rest_of_definition, char_position); end; else do; /* Probably something wrong, but keep going. */ saved_attributes = substr (l6_file_definition.rest_of_definition, char_position); end; do while (char_position <= length (l6_file_definition.rest_of_definition)); /* Loop through the file attributes. */ indicator = substr (l6_file_definition.rest_of_definition, char_position, length (indicator)); char_position = char_position + length (indicator); if indicator = "P" then do; /* File type */ file_type = substr (l6_file_definition.rest_of_definition, char_position, length (file_type)); char_position = char_position + length (file_type); level_6_file_type = index (string (L6_FILE_TYPE), file_type); if level_6_file_type = 0 then call ERROR (error_table_$bad_file, "The Level 6 file type: ""^a"", is not supported.", file_type); end; else if indicator = "Q" then do; /* Data type */ data_type = substr (l6_file_definition.rest_of_definition, char_position, length (data_type)); char_position = char_position + length (data_type); level_6_data_type = index (string (L6_DATA_TYPE), data_type); if level_6_data_type = 0 then call ERROR (error_table_$bad_file, "The Level 6 data type: ""^a"", is not supported.", data_type); end; else if indicator = "R" then do; /* Record size */ string (record_size) = substr (l6_file_definition.rest_of_definition, char_position, length (record_size)); char_position = char_position + length (record_size); level_6_max_record_size = record_size; end; else if indicator = "S" then do; /* Starting record */ string (starting_record) = substr (l6_file_definition.rest_of_definition, char_position, length (starting_record)); char_position = char_position + length (starting_record); end; else if indicator = "T" then do; /* File access code */ file_access = substr (l6_file_definition.rest_of_definition, char_position, length (file_access)); char_position = char_position + length (file_access); end; else if indicator = "U" then do; /* Key length */ string (key_length) = substr (l6_file_definition.rest_of_definition, char_position, length (key_length)) ; char_position = char_position + length (key_length); end; else if indicator = "V" then do; /* Key offset */ string (key_offset) = substr (l6_file_definition.rest_of_definition, char_position, length (key_offset)) ; char_position = char_position + length (key_offset); end; else if indicator = "W" then do; /* Percent fill */ string (percent_fill) = substr (l6_file_definition.rest_of_definition, char_position, length (percent_fill)); char_position = char_position + length (percent_fill); end; else if indicator = "X" then do; /* Key type */ key_type = substr (l6_file_definition.rest_of_definition, char_position, length (key_type)); char_position = char_position + length (key_type); end; else if indicator = "Y" then do; /* CI size */ string (ci_size) = substr (l6_file_definition.rest_of_definition, char_position, length (ci_size)); char_position = char_position + length (ci_size); end; else if indicator = "Z" then do; /* File size (in CI units) */ string (file_size) = substr (l6_file_definition.rest_of_definition, char_position, length (file_size)); char_position = char_position + length (file_size); end; else if indicator = "[" then do; /* Initiator's file count */ string (initiator_file_count) = substr (l6_file_definition.rest_of_definition, char_position, length (initiator_file_count)); char_position = char_position + length (initiator_file_count); end; else if indicator = "\" then do; /* Acceptor's file count */ string (acceptor_file_count) = substr (l6_file_definition.rest_of_definition, char_position, length (acceptor_file_count)); char_position = char_position + length (acceptor_file_count); end; else ; /* Not recognized, skip it */ end; /* Loop through the attributes. */ end; /* Process the file attributes. */ /* Now do the right things to attach and open the Multics file based on everything we have learned. */ if multics_is_sender then do; /* We must describe the file to the Level 6. */ call Get_Next_Path (last_file); /* This sets level_6_pathname too. */ info.info_version = vfs_version_1; call vfile_status_ (multics_dir, multics_entry, addr (info), code); if code ^= 0 then call ERROR (code, "Trying to get vfile_status_ on: ^a, for sending.", multics_pathname); call Check_Multics_File (); call Open_Multics_File (); call Get_Saved_Attributes (); end; /* We must describe the file to the Level 6. */ else do; /* The Level 6 has told us about the file. */ level_6_pathname = ""; /* Not needed since we are receiving. */ star_names_generated = "0"b; /* We never get starnames when receiving. */ info.info_version = vfs_version_1; call vfile_status_ (multics_dir, multics_entry, addr (info), code); if code = 0 then do; call Check_Multics_File (); call Verify_File_Attributes (); end; else call Create_Multics_File (); call Open_Multics_File (); call Set_Saved_Attributes (); end; /* The Level 6 has told us about the file. */ /* Send our response to the Level 6. */ l6_path_len = length (rtrim (level_6_pathname)) + 1; call ioa_$rsnpnnl ("8000$^[^[!^2a^a ^;^2s^]^[#P^aQ^a^s^;^2s#^a^]^;^]", comm_buffer, level_6_chars_to_write, multics_is_sender, star_names_generated, l6_path_len, rtrim (level_6_pathname), saved_attributes = "", L6_FILE_TYPE (multics_file_l6_type), L6_DATA_TYPE (multics_data_type), saved_attributes); output_message_len = level_6_chars_to_write; substr (comm_buffer, 2, 3) = output_message_len; call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to send the ack to the Level 6 file definition."); /* We may have to put a call to write_status here, to prevent our response from being combined with our first prompt. */ return; Check_Multics_File: proc (); multics_file_type = info.type; if multics_file_type > BLOCKED_FILE_TYPE then call ERROR (error_table_$bad_file, "The Multics file must be unstructured, sequential, or blocked. File ^a was ^a.", multics_pathname, FILE_TYPE_TO_PNAME (multics_file_type)); if multics_file_type = BLOCKED_FILE_TYPE then do; multics_file_block_size = blk_info.max_rec_len; multics_file_size = blk_info.end_pos; end; else do; multics_file_block_size = 0; multics_file_size = 0; end; multics_file_l6_type = L6_S_FILE_TYPE; /* This is the default. */ /* Now find out if the file is special by looking for the suffix we put on it. */ status_area_ptr = get_user_free_area_ (); status_ptr = addr (auto_status_branch); call hcs_$status_ (multics_dir, multics_entry, CHASE, status_ptr, status_area_ptr, code); if code ^= 0 then call ERROR (code, "Trying to get status for: ^a.", multics_pathname); if status_branch.short.type = Directory then call ERROR (error_table_$dirseg, "^a.", multics_pathname); code = 1; /* Go through the loop at least once. */ do i = lbound (status_entry_names, 1) to hbound (status_entry_names, 1) while (code ^= 0); call match_star_name_ ((status_entry_names (i)), "**.*.l6*", code); if code = 0 then do; suffix = reverse (before (reverse (rtrim (status_entry_names (i))), ".")); do i = lbound (MULTICS_L6_FILE_SUFFIX, 1) to hbound (MULTICS_L6_FILE_SUFFIX, 1) while (suffix ^= MULTICS_L6_FILE_SUFFIX (i)); end; if i > hbound (MULTICS_L6_FILE_SUFFIX, 1) then code = 1; /* Keep looking. */ else multics_file_l6_type = i; end; end; if status_branch.nnames > 0 & status_branch.names_relp ^= "0"b then free status_entry_names in (status_area_ptr -> based_area); /* Cleanup after ourselves. */ if multics_file_type = UNSTRUCTURED_FILE_TYPE then multics_data_type = ASCII; else multics_data_type = BINARY; return; end Check_Multics_File; Create_Multics_File: proc (); multics_file_l6_type = level_6_file_type; multics_data_type = level_6_data_type; if level_6_file_type = L6_S_FILE_TYPE & level_6_data_type = ASCII then multics_file_type = UNSTRUCTURED_FILE_TYPE; else if level_6_file_type = L6_S_FILE_TYPE then multics_file_type = SEQUENTIAL_FILE_TYPE; else multics_file_type = BLOCKED_FILE_TYPE; if multics_file_type = BLOCKED_FILE_TYPE then do; if level_6_max_record_size = 0 then multics_file_block_size = 256;/*Set default. */ else multics_file_block_size = level_6_max_record_size; end; else multics_file_block_size = 0; multics_file_size = 0; if MULTICS_L6_FILE_SUFFIX (multics_file_l6_type) ^= "" then do; call suffixed_name_$make (multics_entry, MULTICS_L6_FILE_SUFFIX (multics_file_l6_type), multics_entry, code); if code ^= 0 then call ERROR (code, "Trying to add the suffix ""^a"" to ^a", MULTICS_L6_FILE_SUFFIX (multics_file_l6_type), multics_pathname); multics_pathname = pathname_ (multics_dir, multics_entry); end; call hcs_$append_branch (multics_dir, multics_entry, RW_ACCESS_BIN, code); if code ^= 0 then call ERROR (code, "Trying to create: ^a.", multics_pathname); return; end Create_Multics_File; Get_Next_Path: proc (P_last_file); dcl P_last_file bit (1) parameter; dcl code fixed bin (35); call check_star_name_$entry (saved_multics_entry, code); if code = 0 then P_last_file = "1"b; /* Not a star name, nothing to do. */ else if code = error_table_$badstar then call ERROR (code, "Multics file name: ^a.", saved_multics_entry); else do; /* We have a star name. */ if ^star_names_generated then do; /* Get the star list once. */ star_area_ptr = get_user_free_area_ (); call hcs_$star_ (multics_dir, saved_multics_entry, star_ALL_ENTRIES, star_area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then call ERROR (code, "Trying to match starname ^a in directory ^a.", saved_multics_entry, multics_dir); /* Set the index to the first non-directory entry. */ do star_entries_index = 1 to hbound (star_entries, 1) while (star_entries (star_entries_index).type = star_DIRECTORY); end; if star_entries_index > hbound (star_entries, 1) then call ERROR (error_table_$dirseg, "Only directories match ^a.", multics_pathname); star_names_generated = "1"b; end; /* Get the star list once. */ /* Just use the first matching name on an entry. */ multics_entry = star_names (star_entries (star_entries_index).nindex); multics_pathname = pathname_ (multics_dir, multics_entry); /* Now update the star_entries_index and set P_last_file. */ do star_entries_index = star_entries_index + 1 to hbound (star_entries, 1) while (star_entries (star_entries_index).type = star_DIRECTORY); end; if star_entries_index > hbound (star_entries, 1) then P_last_file = "1"b; else P_last_file = "0"b; end; /* We have a star name. */ /* Now generate the L6 pathname. */ call get_equal_name_ (multics_entry, saved_level_6_entry, level_6_entry, code); if code ^= 0 then call ERROR (code, "Trying to do equalname matching on L6 name ^a, against Multics name ~a.", saved_level_6_entry, multics_entry); level_6_pathname = rtrim (level_6_dir) || level_6_entry; return; end Get_Next_Path; Get_Saved_Attributes: proc (); if multics_file_l6_type ^= L6_S_FILE_TYPE then do; call iox_$read_record (multics_file_iocbp, file_buffer_ptr, file_buffer_len, multics_chars_read, code) ; if code ^= 0 then call ERROR (code, "Trying to get the file attributes from the multics file: ^a.", multics_pathname); saved_attributes = substr (file_buffer, 1, multics_chars_read); end; else saved_attributes = ""; return; end Get_Saved_Attributes; Open_Multics_File: proc (); call ioa_$rsnnl ("^[record_stream_ -target ^]vfile_ ^a^[ -blocked ^d^;^s^]", multics_file_attach_desc, ignored_len, multics_file_type = UNSTRUCTURED_FILE_TYPE, multics_pathname, multics_file_type = BLOCKED_FILE_TYPE, multics_file_block_size); call iox_$attach_name (multics_entry, multics_file_iocbp, (multics_file_attach_desc), null (), code); if code ^= 0 & code ^= error_table_$not_detached then call ERROR (code, "Trying to attach file: ^a through switch: ^a.", multics_pathname, multics_entry); if multics_is_sender then multics_file_open_mode = Sequential_input; else multics_file_open_mode = Sequential_output; call iox_$open (multics_file_iocbp, multics_file_open_mode, "0"b, code); if code ^= 0 & code ^= error_table_$not_closed then call ERROR (code, "Trying to open file: ^a through switch: ^a.", multics_pathname, multics_entry); return; end Open_Multics_File; Set_Saved_Attributes: proc (); if multics_file_l6_type ^= L6_S_FILE_TYPE then do; multics_chars_to_write = length (saved_attributes); substr (file_buffer, 1, multics_chars_to_write) = saved_attributes; call iox_$write_record (multics_file_iocbp, file_buffer_ptr, multics_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to save the file attributes in: ^a.", multics_pathname); end; return; end Set_Saved_Attributes; Verify_File_Attributes: proc (); if multics_file_l6_type ^= level_6_file_type then call ERROR (error_table_$bad_file, "The Level 6 file type does not match the existing Multics file type. (M = ^a, L6 = ^a).", L6_FILE_TYPE (multics_file_l6_type), L6_FILE_TYPE (level_6_file_type)); if multics_file_type = BLOCKED_FILE_TYPE & multics_file_block_size < level_6_max_record_size then call ERROR (error_table_$bad_file, "The Multics fiel block size is less than the Level 6 record size. (M = ^d, L6 = ^d).", multics_file_block_size, level_6_max_record_size); if multics_file_type = UNSTRUCTURED_FILE_TYPE & ^(level_6_file_type = L6_S_FILE_TYPE & level_6_data_type = ASCII) then call ERROR (error_table_$bad_file, "Only a sequential ascii Level 6 file may be transferred to an unstructured Multics file."); return; end Verify_File_Attributes; end File_Definition_Dialogue; OK_Dialogue: proc (); call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read ""OK?"" from the Level 6."); if substr (comm_buffer, 1, level_6_chars_read) ^= "OK?" then ; /* Something wrong, but keep going anyway. */ level_6_chars_to_write = length ("OK"); substr (comm_buffer, 1, level_6_chars_to_write) = "OK"; call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to send ""OK"" to the Level 6."); return; end OK_Dialogue; /*****************************************************************************/ /* */ /* PROCEDURE: ERROR */ /* */ /* This subroutine expects arguments as follows: */ /* */ /* call ERROR (code, ioa_control_string, ioa_arguments, ...) */ /* */ /* where: code is fixed bin (35), and ioa_control_string and ioa_arguments */ /* are optional character strings as defined for ioa_. */ /* */ /* Some global variables are used: */ /* */ /* Cleanup_Handler (a procedure that does cleanup) */ /* */ /* For commands: */ /* report_error (an entry variable set to com_err_ or active_fnc_err_)*/ /* command_name (the character string name of the command) */ /* return_arg_ptr (used to return "false" for active functions) */ /* */ /* For subroutines: */ /* depends on the error reporting strategy chosen. */ /* */ /* At completion a non-local goto is done to the label RETURN. */ /* */ /* Declarations are expected for: */ /* */ /* cu_$arg_list_ptr */ /* cu_$arg_ptr */ /* cu_$arg_count */ /* error_table_$fatal_error */ /* ioa_$general_rs */ /* */ /*****************************************************************************/ ERROR: proc () options (variable, non_quick); dcl arg_list_ptr ptr; dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl based_code fixed bin (35) based; dcl caller_code fixed bin (35); dcl code fixed bin (35); dcl err_msg char (256); dcl err_msg_len fixed bin (21); dcl nargs fixed bin; call cu_$arg_count (nargs, code); /* IGNORE CODE */ if nargs >= 1 then do; /* We were called correctly. */ arg_ptr = null (); /* Set this so we know if cu_$arg_ptr worked. */ call cu_$arg_ptr (1, arg_ptr, arg_len, code); if arg_ptr ^= null () then caller_code = arg_ptr -> based_code; /* The normal case. */ else caller_code = error_table_$fatal_error; /* Some problem with our arg list. */ if nargs > 1 then do; /* There is a message. */ call cu_$arg_list_ptr (arg_list_ptr); call ioa_$general_rs (arg_list_ptr, 2, 3, err_msg, err_msg_len, "1"b, "0"b); end; else do; /* No message. */ err_msg = ""; err_msg_len = 0; end; end; /* We were called correctly. */ else do; /* We were called with no arguments. */ caller_code = error_table_$fatal_error; /* The best we can do. */ err_msg = ""; err_msg_len = 0; end; /* We were called with no arguments. */ /* The following lines must be modified depending on the error reporting strategy used. */ if level_6_iocbp ^= null () & comm_buffer_ptr ^= null () then do; /* Tell the Level 6. */ dcl pic_err_msg_len pic "99"; pic_err_msg_len = min (99, err_msg_len); call ioa_$rsnpnnl ("CU^a^aR", comm_buffer, level_6_chars_to_write, pic_err_msg_len, substr (err_msg, 1, pic_err_msg_len)); call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); end; P_error_message = substr (err_msg, 1, err_msg_len); P_code = caller_code; /* Clean up and do a non-local goto back to the outermost block. */ call Cleanup_Handler (); goto RETURN; end ERROR; Cleanup_Handler: proc (); dcl code fixed bin (35); if status_area_ptr ^= null () & status_ptr ^= null () then do; if status_branch.nnames > 1 & status_branch.names_relp ^= "0"b then free status_entry_names in (status_area_ptr -> based_area); end; if star_area_ptr ^= null () then do; /* Order is important here. */ if star_names_ptr ^= null () & star_entry_ptr ^= null () then free star_names in (star_area_ptr -> based_area); if star_entry_ptr ^= null () then free star_entries in (star_area_ptr -> based_area); end; if multics_file_iocbp ^= null () then do; call iox_$close (multics_file_iocbp, code); call iox_$detach_iocb (multics_file_iocbp, code); call iox_$destroy_iocb (multics_file_iocbp, code); end; if file_buffer_ptr ^= null () | comm_buffer_ptr ^= null () then call release_temp_segments_ ("l6_tran_", temp_seg_ptrs, code); return; end Cleanup_Handler; debug_on: entry (); debug_flag = "1"b; return; debug_off: entry (); debug_flag = "0"b; return; end l6_tran_overseer_;  l6_tran_receive_file_.pl1 07/21/83 1210.3r w 07/21/83 1115.1 156591 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /*****************************************************************************/ /* */ /* DESCRIPTION: */ /* */ /* This subroutine does all the work necessary to receive a file from */ /* the Level 6. It is used by the l6_tran_ NASP and l6_tran_overseer_. */ /* */ /* */ /* JOURNALIZATION: */ /* */ /* 1) Written 5/82 by R.J.C. Kissel. */ /* 2) Modified 7/83 by R.J.C. Kissel to fix an error message sent to the L6*/ /* */ /*****************************************************************************/ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */ l6_tran_receive_file_: proc (P_input_args_ptr, P_output_args_ptr, P_error_message, P_code); /* Parameters */ dcl P_input_args_ptr ptr parameter; dcl P_output_args_ptr ptr parameter; dcl P_error_message char (*) varying parameter; dcl P_code fixed bin (35) parameter; /* Automatic */ dcl comm_buffer char (comm_buffer_len) based (comm_buffer_ptr); dcl comm_buffer_len fixed bin (21); dcl comm_buffer_ptr ptr; dcl comm_buffer_position fixed bin (21); dcl char_position_in_tu fixed bin (21); dcl code fixed bin (35); dcl end_of_file bit (1); dcl file_buffer char (file_buffer_len) based (file_buffer_ptr); dcl file_buffer_len fixed bin (21); dcl file_buffer_ptr ptr; dcl last_file bit (1); dcl level_6_chars_read fixed bin (21); dcl level_6_chars_to_write fixed bin (21); dcl level_6_iocbp ptr; dcl multics_chars_to_write fixed bin (21); dcl multics_data_type fixed bin; dcl multics_file_iocbp ptr; dcl multics_file_type fixed bin; dcl next_transmission_unit fixed bin; dcl 1 prompt aligned, 2 prompt_char char (1) unaligned init ("P"), 2 record_number pic "99999" unaligned; dcl record_number fixed bin; dcl total_bytes fixed bin (35); dcl tu_size fixed bin (21); /* Internal Constants */ %include l6_tran_constants; /* External Constants */ dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$fatal_error fixed bin (35) ext static; /* External Entries */ dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_dec_ entry (char (*)) returns (fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned); dcl ioa_$rsnpnnl entry options (variable); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl l6_tran_util_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl l6_tran_util_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); /* Builtin Functions and Conditions */ dcl copy builtin; dcl index builtin; dcl length builtin; dcl min builtin; dcl null builtin; dcl string builtin; dcl substr builtin; dcl verify builtin; /* Include Files */ %include l6_tran_transfer_args; level_6_iocbp = null (); /* Initialize these in case of error. */ comm_buffer_ptr = null (); tiap = P_input_args_ptr; toap = P_output_args_ptr; if transfer_input_args.version ^= transfer_input_args_version_1 then call ERROR (error_table_$unimplemented_version, "The input args version was ^a, expected ^a.", transfer_input_args.version, transfer_input_args_version_1); if transfer_output_args.version ^= transfer_output_args_version_1 then call ERROR (error_table_$unimplemented_version, "The output args version was ^a, expected ^a.", transfer_output_args.version, transfer_output_args_version_1); level_6_iocbp = transfer_input_args.comm_iocbp; comm_buffer_ptr = transfer_input_args.comm_buffer_ptr; comm_buffer_len = transfer_input_args.comm_buffer_len; multics_file_iocbp = transfer_input_args.file_iocbp; file_buffer_ptr = transfer_input_args.file_buffer_ptr; file_buffer_len = transfer_input_args.file_buffer_len; multics_file_type = transfer_input_args.file_type; multics_data_type = transfer_input_args.data_type; tu_size = transfer_input_args.tu_size; total_bytes = 0; comm_buffer_position = 1; /* Set this for Receive_L6_Record */ char_position_in_tu = 1; /* Set this for Receive_L6_Record */ level_6_chars_read = 0; /* Set this for Receive_L6_Record */ next_transmission_unit = 0; /* Set this for Receive_L6_Record */ /* Send the initial prompt for record 0. */ prompt.record_number = 0; level_6_chars_to_write = length (string (prompt)); substr (comm_buffer, 1, level_6_chars_to_write) = string (prompt); call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to write the first prompt to the Level 6."); /* Receive records until we find end of file (returned after the last record is read). */ call Receive_L6_Record (record_number, end_of_file, last_file); /* A level 6 null line has whitespace in it. If we get a whitespace record, write a null line to the Multics file. */ if multics_file_type = UNSTRUCTURED_FILE_TYPE & multics_data_type = ASCII & verify (substr (file_buffer, 1, multics_chars_to_write), SP || HT) = 0 then multics_chars_to_write = 0; do while (^end_of_file); call iox_$write_record (multics_file_iocbp, file_buffer_ptr, multics_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to write record ^d to the multics file.", record_number); total_bytes = total_bytes + multics_chars_to_write; call Receive_L6_Record (record_number, end_of_file, last_file); /* A level 6 null line has whitespace in it. If we get a record of just whitespace, write a null line to the Multics file. */ if multics_file_type = UNSTRUCTURED_FILE_TYPE & multics_data_type = ASCII & verify (substr (file_buffer, 1, multics_chars_to_write), SP || HT) = 0 then multics_chars_to_write = 0; end; /* Send the final prompt for the last record we got. The L6 wants the # of records, not the # of the last record. */ prompt.record_number = min (99999, record_number + 1); level_6_chars_to_write = length (string (prompt)); substr (comm_buffer, 1, level_6_chars_to_write) = string (prompt); call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); if code ^= 0 then call ERROR (code, "Trying to write the final prompt to the Level 6."); transfer_output_args.record_number = record_number; transfer_output_args.total_bytes = total_bytes; transfer_output_args.last_file = last_file; P_error_message = ""; P_code = 0; RETURN: return; Receive_L6_Record: proc (P_record_number, P_end_of_file, P_last_file); dcl P_record_number fixed bin; dcl P_end_of_file bit (1) parameter; dcl P_last_file bit (1) parameter; dcl code fixed bin (35); dcl current_char char (1); dcl current_digit fixed bin; dcl data_chars_available fixed bin; dcl data_field_len char (2); dcl data_is_packed bit (1); dcl end_of_file bit (1); dcl end_of_record bit (1); dcl file_buffer_position fixed bin (21); dcl fixed_data_field_len fixed bin; dcl last_file bit (1); dcl 1 l6_error aligned based (comm_buffer_ptr), 2 first_char char (1) unaligned, /* Should be "C". */ 2 second_char char (1) unaligned, /* Should be "U". */ 2 message_len pic "99" unaligned, 2 message char (0 refer (l6_error.message_len)) unaligned; dcl media_code fixed bin; dcl read_record_state fixed bin; dcl record_number char (5); /* Set initial parser state variables. */ file_buffer_position = 1; read_record_state = 1; current_digit = 1; /* Now parse the record, getting more characters as needed. */ last_file = "0"b; end_of_file = "0"b; end_of_record = "0"b; do while (^end_of_file & ^end_of_record); if comm_buffer_position > level_6_chars_read then do; /* Get some more characters to process. */ call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to get characters for a record."); comm_buffer_position = 1; end; /* Get some more characters to process. */ current_char = substr (comm_buffer, comm_buffer_position, 1); if char_position_in_tu = tu_size + 1 | char_position_in_tu = 1 then do; /* Special transmission unit character. */ char_position_in_tu = 1; if current_char = "C" then call ERROR (error_table_$fatal_error, "Error from the Level 6: ^a.", l6_error.message); if cv_dec_ (current_char) ^= next_transmission_unit then ; /* Something wrong, but keep going. */ next_transmission_unit = next_transmission_unit + 1; comm_buffer_position = comm_buffer_position + 1; char_position_in_tu = char_position_in_tu + 1; goto NEXT_STATE; end; /* Special transmission unit character. */ goto RECORD_PARSER (read_record_state); RECORD_PARSER (1): /* Process the media code or end of file */ if current_char = "E" then do; end_of_file = "1"b; last_file = "1"b; end; else if current_char = "F" then do; end_of_file = "1"b; last_file = "0"b; end; else media_code = index (string (L6_DATA_TYPE), current_char); comm_buffer_position = comm_buffer_position + 1; /* Take any media code. */ char_position_in_tu = char_position_in_tu + 1; read_record_state = 2; goto NEXT_STATE; RECORD_PARSER (2): /* Process the digits of the record number */ substr (record_number, current_digit, 1) = current_char; comm_buffer_position = comm_buffer_position + 1; current_digit = current_digit + 1; char_position_in_tu = char_position_in_tu + 1; if current_digit <= length (record_number) then read_record_state = 2; else do; current_digit = 1; read_record_state = 3; end; goto NEXT_STATE; RECORD_PARSER (3): /* Process packed (P), unpacked (U), or end of record (R) */ if current_char = "P" then data_is_packed = "1"b; else if current_char = "U" then data_is_packed = "0"b; else if current_char = "R" then end_of_record = "1"b; else do; /* Assume end of record */ end_of_record = "1"b; goto NEXT_STATE; /* Don't advance buffer position */ end; comm_buffer_position = comm_buffer_position + 1; char_position_in_tu = char_position_in_tu + 1; read_record_state = 4; goto NEXT_STATE; RECORD_PARSER (4): /* Process the digits of the data field length */ substr (data_field_len, current_digit, 1) = current_char; comm_buffer_position = comm_buffer_position + 1; current_digit = current_digit + 1; char_position_in_tu = char_position_in_tu + 1; if current_digit <= length (data_field_len) then read_record_state = 4; else do; current_digit = 1; fixed_data_field_len = cv_dec_check_ (data_field_len, code); if code ^= 0 then fixed_data_field_len = 0; code = 0; read_record_state = 5; end; goto NEXT_STATE; RECORD_PARSER (5): /* Process a data field, we may not have it all. */ if data_is_packed then do; substr (file_buffer, file_buffer_position, fixed_data_field_len) = copy (current_char, fixed_data_field_len); file_buffer_position = file_buffer_position + fixed_data_field_len; comm_buffer_position = comm_buffer_position + 1; char_position_in_tu = char_position_in_tu + 1; read_record_state = 3; end; else do; data_chars_available = min (fixed_data_field_len, level_6_chars_read - comm_buffer_position + 1); substr (file_buffer, file_buffer_position, data_chars_available) = substr (comm_buffer, comm_buffer_position, data_chars_available); file_buffer_position = file_buffer_position + data_chars_available; comm_buffer_position = comm_buffer_position + data_chars_available; char_position_in_tu = char_position_in_tu + data_chars_available; fixed_data_field_len = fixed_data_field_len - data_chars_available; if fixed_data_field_len <= 0 then read_record_state = 3; /* done with the data. */ else read_record_state = 5; /* more unpacked data. */ end; goto NEXT_STATE; NEXT_STATE: end; /* Parser loop */ multics_chars_to_write = file_buffer_position - 1; P_last_file = last_file; P_end_of_file = end_of_file; /* Only eof or eor may be set, not both. */ P_record_number = cv_dec_check_ (record_number, code); if code ^= 0 then P_record_number = 0; return; end Receive_L6_Record; /*****************************************************************************/ /* */ /* PROCEDURE: ERROR */ /* */ /* This subroutine expects arguments as follows: */ /* */ /* call ERROR (code, ioa_control_string, ioa_arguments, ...) */ /* */ /* where: code is fixed bin (35), and ioa_control_string and ioa_arguments */ /* are optional character strings as defined for ioa_. */ /* */ /* Some global variables are used: */ /* */ /* Cleanup_Handler (a procedure that does cleanup) */ /* */ /* For commands: */ /* report_error (an entry variable set to com_err_ or active_fnc_err_)*/ /* command_name (the character string name of the command) */ /* return_arg_ptr (used to return "false" for active functions) */ /* */ /* For subroutines: */ /* depends on the error reporting strategy chosen. */ /* */ /* At completion a non-local goto is done to the label RETURN. */ /* */ /* Declarations are expected for: */ /* */ /* cu_$arg_list_ptr */ /* cu_$arg_ptr */ /* cu_$arg_count */ /* error_table_$fatal_error */ /* ioa_$general_rs */ /* */ /*****************************************************************************/ ERROR: proc () options (variable, non_quick); dcl arg_list_ptr ptr; dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl based_code fixed bin (35) based; dcl caller_code fixed bin (35); dcl code fixed bin (35); dcl err_msg char (256); dcl err_msg_len fixed bin (21); dcl nargs fixed bin; call cu_$arg_count (nargs, code); /* IGNORE CODE */ if nargs >= 1 then do; /* We were called correctly. */ arg_ptr = null (); /* Set this so we know if cu_$arg_ptr worked. */ call cu_$arg_ptr (1, arg_ptr, arg_len, code); if arg_ptr ^= null () then caller_code = arg_ptr -> based_code; /* The normal case. */ else caller_code = error_table_$fatal_error; /* Some problem with our arg list. */ if nargs > 1 then do; /* There is a message. */ call cu_$arg_list_ptr (arg_list_ptr); call ioa_$general_rs (arg_list_ptr, 2, 3, err_msg, err_msg_len, "1"b, "0"b); end; else do; /* No message. */ err_msg = ""; err_msg_len = 0; end; end; /* We were called correctly. */ else do; /* We were called with no arguments. */ caller_code = error_table_$fatal_error; /* The best we can do. */ err_msg = ""; err_msg_len = 0; end; /* We were called with no arguments. */ /* The following lines must be modified depending on the error reporting strategy used. */ if level_6_iocbp ^= null () & comm_buffer_ptr ^= null () then do; /* Tell the Level 6. */ dcl pic_err_msg_len pic "99"; pic_err_msg_len = min (99, err_msg_len); call ioa_$rsnpnnl ("CU^a^aR", comm_buffer, level_6_chars_to_write, pic_err_msg_len, substr (err_msg, 1, pic_err_msg_len)); call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); end; P_error_message = substr (err_msg, 1, err_msg_len); P_code = caller_code; /* Clean up and do a non-local goto back to the outermost block. */ call Cleanup_Handler (); goto RETURN; end ERROR; Cleanup_Handler: proc (); return; /* Nothing to do for now. */ end Cleanup_Handler; end l6_tran_receive_file_;  l6_tran_send_file_.pl1 10/05/83 1349.7rew 10/05/83 1332.6 182097 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /*****************************************************************************/ /* */ /* DESCRIPTION: */ /* */ /* This subroutine does all of the work necessary to send a file to */ /* the Level 6. It is used by the l6_tran_ NASP. */ /* */ /* */ /* JOURNALIZATION: */ /* */ /* 1) Written 5/82 by R.J.C. Kissel. */ /* 2) Modified 7/83 by R.J.C. Kissel to check for an error message from */ /* the L6 after every transmission unit is sent. */ /* 3) Modified 9/83 by R.J.C. Kissel to not call the final prompt after a */ /* file transfer an error. */ /* */ /*****************************************************************************/ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */ l6_tran_send_file_: proc (P_input_args_ptr, P_output_args_ptr, P_error_message, P_code); /* Parameters */ dcl P_input_args_ptr ptr parameter; dcl P_output_args_ptr ptr parameter; dcl P_error_message char (*) varying parameter; dcl P_code fixed bin (35) parameter; /* Automatic */ dcl comm_buffer char (comm_buffer_len) based (comm_buffer_ptr); dcl comm_buffer_len fixed bin (21); dcl comm_buffer_ptr ptr; dcl comm_buffer_position fixed bin (21); dcl code fixed bin (35); dcl end_of_file bit (1); dcl file_buffer char (file_buffer_len) based (file_buffer_ptr); dcl file_buffer_len fixed bin (21); dcl file_buffer_ptr ptr; dcl last_file bit (1); dcl level_6_chars_read fixed bin (21); dcl level_6_chars_to_write fixed bin (21); dcl level_6_iocbp ptr; dcl multics_chars_read fixed bin (21); dcl multics_data_type fixed bin; dcl multics_file_type fixed bin; dcl multics_file_iocbp ptr; dcl next_transmission_unit fixed bin; dcl 1 prompt aligned, 2 prompt_char char (1) unaligned init ("P"), 2 record_number pic "99999" unaligned; dcl record_number fixed bin; dcl total_bytes fixed bin (35); dcl tu_size fixed bin (21); /* Internal Constants */ %include l6_tran_constants; /* External Constants */ dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$fatal_error fixed bin (35) ext static; dcl error_table_$short_record fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; /* External Entries */ dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned); dcl ioa_$rsnpnnl entry options (variable); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl l6_tran_util_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl l6_tran_util_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl l6_tran_util_$read_status entry (ptr) returns (bit (1)); /* Builtin Functions and Conditions */ dcl length builtin; dcl min builtin; dcl mod builtin; dcl null builtin; dcl string builtin; dcl substr builtin; dcl verify builtin; /* Include Files */ %include l6_tran_transfer_args; level_6_iocbp = null (); /* Initialize these in case of error. */ comm_buffer_ptr = null (); tiap = P_input_args_ptr; toap = P_output_args_ptr; if transfer_input_args.version ^= transfer_input_args_version_1 then call ERROR (error_table_$unimplemented_version, "The input args version was ^a, expected ^a.", transfer_input_args.version, transfer_input_args_version_1); if transfer_output_args.version ^= transfer_output_args_version_1 then call ERROR (error_table_$unimplemented_version, "The output args version was ^a, expected ^a.", transfer_output_args.version, transfer_output_args_version_1); level_6_iocbp = transfer_input_args.comm_iocbp; comm_buffer_ptr = transfer_input_args.comm_buffer_ptr; comm_buffer_len = transfer_input_args.comm_buffer_len; multics_file_iocbp = transfer_input_args.file_iocbp; file_buffer_ptr = transfer_input_args.file_buffer_ptr; file_buffer_len = transfer_input_args.file_buffer_len; multics_file_type = transfer_input_args.file_type; multics_data_type = transfer_input_args.data_type; tu_size = transfer_input_args.tu_size; last_file = transfer_input_args.last_file; total_bytes = 0; comm_buffer_position = 1; /* Set this for Send_L6_Record. */ next_transmission_unit = 0; /* Set this for Send_L6_Record. */ /* Get the first prompt from the Level 6, it should be for record 0. */ if ^transfer_input_args.flags.prompt_read then do; call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read the first prompt from the Level 6."); string (prompt) = substr (comm_buffer, 1, level_6_chars_read); if prompt.record_number ^= 0 then ; /* Something wrong, but keep going. */ end; /* Send records until end of file. (et_$short_record means eof but no newline from iox_$get_line). */ call iox_$read_record (multics_file_iocbp, file_buffer_ptr, file_buffer_len, multics_chars_read, code); if code ^= 0 & code ^= error_table_$end_of_info & code ^= error_table_$short_record then call ERROR (code, "Trying to read the first record from the multics file."); /* The level 6 cannot handle a null record, so if we have one put a space in it and send that. */ if multics_file_type = UNSTRUCTURED_FILE_TYPE & multics_data_type = ASCII & multics_chars_read = 0 then do; multics_chars_read = 1; substr (file_buffer, 1, 1) = " "; end; total_bytes = total_bytes + multics_chars_read; end_of_file = (code = error_table_$end_of_info); do record_number = 0 by 1 while (^end_of_file); /* Send the record if it is non-null, otherwise skip it. */ if multics_chars_read > 0 then call Send_L6_Record (record_number, end_of_file, last_file); else record_number = record_number - 1; /* Ignore null record, do loop will increment this. */ /* Read the next Multics record, and check the error code. */ call iox_$read_record (multics_file_iocbp, file_buffer_ptr, file_buffer_len, multics_chars_read, code); if code ^= 0 & code ^= error_table_$end_of_info & code ^= error_table_$short_record then call ERROR (code, "Trying to read record ^d from the multics file.", record_number + 1); /* The level 6 cannot handle a null record, so if we have one put a space in it and send that. */ if multics_file_type = UNSTRUCTURED_FILE_TYPE & multics_data_type = ASCII & multics_chars_read = 0 then do; multics_chars_read = 1; substr (file_buffer, 1, 1) = " "; end; total_bytes = total_bytes + multics_chars_read; end_of_file = (code = error_table_$end_of_info); end; call Send_L6_Record (record_number, end_of_file, last_file); /* Write the end of file record. */ /* Get the final prompt from the Level 6, it might be an error message. */ call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read the final prompt from the Level 6."); call Check_For_L6_Error ((record_number)); transfer_output_args.record_number = record_number; transfer_output_args.total_bytes = total_bytes; P_error_message = ""; P_code = 0; RETURN: return; Send_L6_Record: proc (P_record_number, P_end_of_file, P_last_file); dcl P_record_number fixed bin parameter; dcl P_end_of_file bit (1) parameter; dcl P_last_file bit (1) parameter; dcl chars_left_in_record fixed bin (21); dcl code fixed bin (35); dcl current_digit fixed bin; dcl data_field_len pic "99"; dcl end_of_record bit (1); dcl file_buffer_position fixed bin (21); dcl max_unpacked_chars fixed bin; dcl media_code char (1); dcl pic_next_tu pic "9"; dcl pack_the_data bit (1); dcl packable_index fixed bin; dcl packable_string bit (1); dcl possible_packed_char char (1); dcl possible_packed_length fixed bin; dcl record_number pic "99999"; dcl write_record_state fixed bin; current_digit = 1; file_buffer_position = 1; media_code = L6_DATA_TYPE (multics_data_type); record_number = min (99999, P_record_number); write_record_state = 1; end_of_record = "0"b; do while (^end_of_record); /* Output loop. */ if comm_buffer_position = tu_size + 1 | comm_buffer_position = 1 then do; if comm_buffer_position = tu_size + 1 then do; /* Normal case, = 1 only the first time. */ call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, tu_size, code); if code ^= 0 then call ERROR (code, "Trying to write transmission unit."); /* Look and see if the L6 has sent us something (usually an error message). */ if l6_tran_util_$read_status (level_6_iocbp) then do; call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code); if code ^= 0 then call ERROR (code, "Trying to read a message from the Level 6 after sending record ^d." , record_number); call Check_For_L6_Error ((record_number)); end; end; comm_buffer_position = 1; pic_next_tu = next_transmission_unit; substr (comm_buffer, comm_buffer_position, 1) = string (pic_next_tu); comm_buffer_position = comm_buffer_position + 1; next_transmission_unit = mod (next_transmission_unit + 1, 10); goto NEXT_STATE; end; goto WRITE_RECORD (write_record_state); WRITE_RECORD (1): /* Put in the media code */ if P_end_of_file then do; if P_last_file then substr (comm_buffer, comm_buffer_position, 1) = "E"; else substr (comm_buffer, comm_buffer_position, 1) = "F"; call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_position, code); if code ^= 0 then call ERROR (code, "Trying to write the last tu."); end_of_record = "1"b; /* Exit the loop. */ end; else substr (comm_buffer, comm_buffer_position, 1) = media_code; comm_buffer_position = comm_buffer_position + 1; write_record_state = 2; goto NEXT_STATE; WRITE_RECORD (2): /* Put in the record number, one digit at a time. */ substr (comm_buffer, comm_buffer_position, 1) = substr (record_number, current_digit, 1); comm_buffer_position = comm_buffer_position + 1; current_digit = current_digit + 1; if current_digit <= length (record_number) then write_record_state = 2; else do; current_digit = 1; write_record_state = 3; end; goto NEXT_STATE; WRITE_RECORD (3): /* Decide to pack, unpack (and how much), or end record. */ chars_left_in_record = multics_chars_read - file_buffer_position + 1; if chars_left_in_record <= 0 then do; /* Done with the record data. */ substr (comm_buffer, comm_buffer_position, 1) = "R"; comm_buffer_position = comm_buffer_position + 1; end_of_record = "1"b; /* Exit the loop. */ goto NEXT_STATE; end; /* Find the longest unpackable string in what is left. If one is not found, use what is left. */ packable_string = "0"b; do packable_index = 0 to min (99, chars_left_in_record) - 1 while (^packable_string); possible_packed_char = substr (file_buffer, file_buffer_position + packable_index, 1); possible_packed_length = verify ( substr (file_buffer, file_buffer_position + packable_index + 1, min (99, chars_left_in_record) - packable_index - 1), possible_packed_char); if possible_packed_length = 0 & min (99, chars_left_in_record) - packable_index - 1 > 0 then possible_packed_length = min (99, chars_left_in_record) - packable_index; if possible_packed_length >= 5 then packable_string = "1"b; else packable_string = "0"b; end; packable_index = packable_index - 1; if packable_string & packable_index = 0 then pack_the_data = "1"b; else if packable_string & packable_index > 0 then do; pack_the_data = "0"b; max_unpacked_chars = (tu_size - comm_buffer_position + 1) - 3; if max_unpacked_chars <= 0 | max_unpacked_chars >= 99 then max_unpacked_chars = 99; max_unpacked_chars = min (max_unpacked_chars, packable_index); end; else do; pack_the_data = "0"b; max_unpacked_chars = (tu_size - comm_buffer_position + 1) - 3; if max_unpacked_chars <= 0 | max_unpacked_chars >= 99 then max_unpacked_chars = 99; max_unpacked_chars = min (max_unpacked_chars, chars_left_in_record); end; /* Now put in "P" or "U" as appropriate, and set the length. */ if pack_the_data then do; data_field_len = possible_packed_length; substr (comm_buffer, comm_buffer_position, 1) = "P"; end; else do; data_field_len = max_unpacked_chars; substr (comm_buffer, comm_buffer_position, 1) = "U"; end; comm_buffer_position = comm_buffer_position + 1; write_record_state = 4; goto NEXT_STATE; WRITE_RECORD (4): /* Put in the data length, one digit at a time. */ substr (comm_buffer, comm_buffer_position, 1) = substr (data_field_len, current_digit, 1); comm_buffer_position = comm_buffer_position + 1; current_digit = current_digit + 1; if current_digit <= length (string (data_field_len)) then write_record_state = 4; else do; current_digit = 1; write_record_state = 5; end; goto NEXT_STATE; WRITE_RECORD (5): /* Now put in the data, it won't cross the tu boundary. */ if pack_the_data then do; substr (comm_buffer, comm_buffer_position, 1) = possible_packed_char; comm_buffer_position = comm_buffer_position + 1; file_buffer_position = file_buffer_position + possible_packed_length; end; else do; substr (comm_buffer, comm_buffer_position, max_unpacked_chars) = substr (file_buffer, file_buffer_position, max_unpacked_chars); comm_buffer_position = comm_buffer_position + max_unpacked_chars; file_buffer_position = file_buffer_position + max_unpacked_chars; end; write_record_state = 3; goto NEXT_STATE; NEXT_STATE: end; /* Output loop. */ return; end Send_L6_Record; Check_For_L6_Error: proc (current_multics_record); dcl current_multics_record fixed bin; dcl 1 l6_error aligned based (comm_buffer_ptr), /* L6 error message overlay. */ 2 header, 3 first_char char (1) unaligned, /* Should be "C". */ 3 second_char char (1) unaligned, /* Should be "U". */ 3 message_len pic "99" unaligned, 2 message char (0 refer (l6_error.header.message_len)) unaligned; dcl strange_error char (level_6_chars_read) based (comm_buffer_ptr); if level_6_chars_read > 0 then do; /* Something to look at. */ if l6_error.first_char = "C" & level_6_chars_read >= length (string (l6_error.header)) then call ERROR (error_table_$fatal_error, "Error from the Level 6 after sending record ^d: ^a.", current_multics_record, l6_error.message); else if l6_error.first_char = "P" & level_6_chars_read = length (string (prompt)) then ; /* This is not an error, just a prompt. */ else call ERROR (error_table_$fatal_error, "Error from the Level 6 after sending record ^d: ^a.", current_multics_record, strange_error); end; return; end Check_For_L6_Error; /*****************************************************************************/ /* */ /* PROCEDURE: ERROR */ /* */ /* This subroutine expects arguments as follows: */ /* */ /* call ERROR (code, ioa_control_string, ioa_arguments, ...) */ /* */ /* where: code is fixed bin (35), and ioa_control_string and ioa_arguments */ /* are optional character strings as defined for ioa_. */ /* */ /* Some global variables are used: */ /* */ /* Cleanup_Handler (a procedure that does cleanup) */ /* */ /* For commands: */ /* report_error (an entry variable set to com_err_ or active_fnc_err_)*/ /* command_name (the character string name of the command) */ /* return_arg_ptr (used to return "false" for active functions) */ /* */ /* For subroutines: */ /* depends on the error reporting strategy chosen. */ /* */ /* At completion a non-local goto is done to the label RETURN. */ /* */ /* Declarations are expected for: */ /* */ /* cu_$arg_list_ptr */ /* cu_$arg_ptr */ /* cu_$arg_count */ /* error_table_$fatal_error */ /* ioa_$general_rs */ /* */ /*****************************************************************************/ ERROR: proc () options (variable, non_quick); dcl arg_list_ptr ptr; dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl based_code fixed bin (35) based; dcl caller_code fixed bin (35); dcl code fixed bin (35); dcl err_msg char (256); dcl err_msg_len fixed bin (21); dcl nargs fixed bin; call cu_$arg_count (nargs, code); /* IGNORE CODE */ if nargs >= 1 then do; /* We were called correctly. */ arg_ptr = null (); /* Set this so we know if cu_$arg_ptr worked. */ call cu_$arg_ptr (1, arg_ptr, arg_len, code); if arg_ptr ^= null () then caller_code = arg_ptr -> based_code; /* The normal case. */ else caller_code = error_table_$fatal_error; /* Some problem with our arg list. */ if nargs > 1 then do; /* There is a message. */ call cu_$arg_list_ptr (arg_list_ptr); call ioa_$general_rs (arg_list_ptr, 2, 3, err_msg, err_msg_len, "1"b, "0"b); end; else do; /* No message. */ err_msg = ""; err_msg_len = 0; end; end; /* We were called correctly. */ else do; /* We were called with no arguments. */ caller_code = error_table_$fatal_error; /* The best we can do. */ err_msg = ""; err_msg_len = 0; end; /* We were called with no arguments. */ /* The following lines must be modified depending on the error reporting strategy used. */ if level_6_iocbp ^= null () & comm_buffer_ptr ^= null () then do; /* Tell the Level 6. */ dcl pic_err_msg_len pic "99"; pic_err_msg_len = min (99, err_msg_len); call ioa_$rsnpnnl ("CU^a^aR", comm_buffer, level_6_chars_to_write, pic_err_msg_len, substr (err_msg, 1, pic_err_msg_len)); call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code); end; P_error_message = substr (err_msg, 1, err_msg_len); P_code = caller_code; /* Clean up and do a non-local goto back to the outermost block. */ call Cleanup_Handler (); goto RETURN; end ERROR; Cleanup_Handler: proc (); return; /* Nothing to do for now. */ end Cleanup_Handler; end l6_tran_send_file_;  l6_tran_util_.pl1 08/08/88 1553.7r w 08/08/88 1410.7 72216 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /*****************************************************************************/ /* */ /* DESCRIPTION: */ /* */ /* This subroutine handles utility functions for Level 6 file */ /* transfer. Basically these are reading and writing to or from the Level */ /* 6. */ /* */ /* */ /* JOURNALIZATION: */ /* */ /* 1) Written 5/82 by R.J.C. Kissel. */ /* 2) Modified 7/83 by R.J.C. Kissel to add an entry to do a read_status, */ /* used to check for L6 error messages. */ /* */ /*****************************************************************************/ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */ l6_tran_util_: proc (); return; /* Parameters */ dcl P_iocbp ptr parameter; dcl P_input_chars_ptr ptr parameter; dcl P_input_buffer_len fixed bin (21) parameter; dcl P_input_chars_len fixed bin (21) parameter; dcl P_output_chars_ptr ptr parameter; dcl P_output_chars_len fixed bin (21) parameter; dcl P_code fixed bin (35) parameter; /* Automatic */ dcl code fixed bin (35); dcl input_chars_ptr ptr; dcl input_buffer_len fixed bin (21); dcl input_chars_len fixed bin (21); dcl input_chars char (input_chars_len) based (input_chars_ptr); dcl iocbp ptr; dcl line_status bit (72); dcl output_chars_ptr ptr; dcl output_chars_len fixed bin (21); dcl output_chars char (output_chars_len) based (output_chars_ptr); dcl 1 read_status_info aligned like tty_read_status_info; /* Internal Static */ dcl debug bit (1) internal static init ("0"b); dcl debug_iocbp ptr internal static init (null ()); /* External Constants */ dcl error_table_$line_status_pending fixed bin (35) ext static; /* External Entries */ dcl ioa_$ioa_switch entry () options (variable); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); 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 ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); /* Builtin Functions and Conditions */ dcl addr builtin; /*****************************************************************************/ /* */ /* ENTRY: get_chars */ /* */ /* This entry gets characters from the Level 6 and handles debugging */ /* and line status. */ /* */ /*****************************************************************************/ get_chars: entry (P_iocbp, P_input_chars_ptr, P_input_buffer_len, P_input_chars_len, P_code); iocbp = P_iocbp; input_chars_ptr = P_input_chars_ptr; input_buffer_len = P_input_buffer_len; call iox_$get_chars (iocbp, input_chars_ptr, input_buffer_len, input_chars_len, code); do while (code = error_table_$line_status_pending); call iox_$control (iocbp, "line_status", addr (line_status), code); if debug then call ioa_$ioa_switch (debug_iocbp, "Line status from L6: ^.3b", line_status); call iox_$get_chars (iocbp, input_chars_ptr, input_buffer_len, input_chars_len, code); end; if debug then call ioa_$ioa_switch (debug_iocbp, "From L6: ^d characters^/""^a""", input_chars_len, input_chars); P_input_chars_len = input_chars_len; P_code = code; return; /*****************************************************************************/ /* */ /* ENTRY: get_line */ /* */ /* This entry gets a line from the Level 6 and handles debugging */ /* and line status. */ /* */ /*****************************************************************************/ get_line: entry (P_iocbp, P_input_chars_ptr, P_input_buffer_len, P_input_chars_len, P_code); iocbp = P_iocbp; input_chars_ptr = P_input_chars_ptr; input_buffer_len = P_input_buffer_len; call iox_$get_line (iocbp, input_chars_ptr, input_buffer_len, input_chars_len, code); do while (code = error_table_$line_status_pending); call iox_$control (iocbp, "line_status", addr (line_status), code); if debug then call ioa_$ioa_switch (debug_iocbp, "Line status from L6: ^.3b", line_status); call iox_$get_line (iocbp, input_chars_ptr, input_buffer_len, input_chars_len, code); end; if debug then call ioa_$ioa_switch (debug_iocbp, "From L6: ^d characters^/""^a""", input_chars_len, input_chars); P_input_chars_len = input_chars_len; P_code = code; return; /*****************************************************************************/ /* */ /* ENTRY: put_chars */ /* */ /* This entry sends characters to the Level 6 and handles debugging */ /* and line status. */ /* */ /*****************************************************************************/ put_chars: entry (P_iocbp, P_output_chars_ptr, P_output_chars_len, P_code); iocbp = P_iocbp; output_chars_ptr = P_output_chars_ptr; output_chars_len = P_output_chars_len; if debug then call ioa_$ioa_switch (debug_iocbp, "To L6: ^d characters^/""^a""", output_chars_len, output_chars); call iox_$put_chars (iocbp, output_chars_ptr, output_chars_len, code); do while (code = error_table_$line_status_pending); call iox_$control (iocbp, "line_status", addr (line_status), code); if debug then call ioa_$ioa_switch (debug_iocbp, "Line status from L6: ^.3b", line_status); call iox_$put_chars (iocbp, output_chars_ptr, output_chars_len, code); end; P_code = code; return; /*****************************************************************************/ /* */ /* ENTRY: read_status */ /* */ /* This entry returns true if there is input pending and false */ /* otherwise. It handles line_status_pending and any error codes. Since */ /* we don't care about wakeups, it also drains the event channel on every */ /* call. */ /* */ /*****************************************************************************/ read_status: entry (P_iocbp) returns (bit (1)); iocbp = P_iocbp; call iox_$control (iocbp, "read_status", addr (read_status_info), code); do while (code = error_table_$line_status_pending); call iox_$control (iocbp, "line_status", addr (line_status), code); if debug then call ioa_$ioa_switch (debug_iocbp, "Line status from L6: ^.3b", line_status); call iox_$control (iocbp, "read_status", addr (read_status_info), code); end; call ipc_$drain_chn (read_status_info.event_channel, code); if debug then call ioa_$ioa_switch (debug_iocbp, "Called read_status, ev_chn = ^o, input_pending = ^b, code = ^d.", read_status_info.event_channel, read_status_info.input_pending, code); return (read_status_info.input_pending); debug_on: entry (); debug = "1"b; return; debug_off: entry (); debug = "0"b; return; set_debug_iocb: entry (diocbp); dcl diocbp ptr; dcl iox_$user_output ptr ext static; dcl null builtin; if diocbp = null () then debug_iocbp = iox_$user_output; else debug_iocbp = diocbp; return; /* Include Files */ %include tty_read_status_info; end l6_tran_util_;  net_info_table_.pl1 11/12/82 1350.6rew 11/12/82 0953.9 16965 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /*****************************************************************************/ /* */ /* This is currently just an internal interface used by the L6 tran */ /* software. It will be the real thing in the future. */ /* */ /*****************************************************************************/ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */ net_info_table_: proc (); return; /* Parameters */ dcl P_code fixed bin (35) parameter; dcl P_function_name char (*) parameter; dcl P_host_address char (*) parameter; dcl P_host_name char (*) parameter; dcl P_nasp_name char (*) parameter; dcl P_net_name char (*) parameter; /* Automatic */ dcl host_name char (32); dcl function_name char (32); dcl net_name char (32); /* External Constants */ dcl error_table_$resource_type_unknown fixed bin (35) ext static; get_host_address: entry (P_host_name, P_net_name, P_host_address, P_code); host_name = P_host_name; net_name = P_net_name; P_host_address = host_name; /* The name is the address for now. */ P_code = 0; return; get_nasp_name: entry (P_function_name, P_nasp_name, P_code); function_name = P_function_name; if function_name ^= "l6_ftf" then do; P_nasp_name = ""; P_code = error_table_$resource_type_unknown; end; else do; P_nasp_name = "l6_tran_"; P_code = 0; end; return; end net_info_table_;  network_request.pl1 11/12/82 1350.6rew 11/12/82 0953.9 98514 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /******************************************************************************/ /* */ /* DESCRIPTION: */ /* */ /* This command implements the general interactive network function */ /* interface. The syntax is: */ /* */ /* nr {} */ /* */ /* The is used to look up the subroutine that implements that */ /* function in the Network Information Table, using the net_info_table_ */ /* entries. That subroutine is then called to do all the work. Basically */ /* this command is just a framework into which different functions can be */ /* plugged. */ /* */ /* */ /* JOURNALIZATION: */ /* */ /* 1) Written 3/82 by R.J.C. Kissel */ /* */ /******************************************************************************/ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */ network_request: nr: proc (); /* Automatic */ dcl arg char (arg_len) based (arg_ptr); dcl arg_idx fixed bin; dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl arg_list_ptr ptr; dcl 1 auto_area_info aligned like area_info; dcl based_area area (sys_info$max_seg_size) based; dcl code fixed bin (35); dcl command_name char (16); dcl function_name char (32); dcl get_argument entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable; dcl in_iocbp ptr; dcl nasp_area_ptr ptr defined (auto_area_info.areap); dcl nasp_complete bit (1); dcl nasp_error_message char (256) varying; dcl nasp_name char (32); dcl nasp_unhold bit (1); dcl nasp_structure bit (nasp_structure_len) based (nasp_structure_ptr) aligned; dcl nasp_structure_len fixed bin (24); dcl nasp_structure_ptr ptr; dcl number_of_args fixed bin; dcl out_iocbp ptr; dcl queued_flag bit (1); dcl report_error entry () options (variable) variable; dcl return_arg char (return_arg_len) based (return_arg_ptr); dcl return_arg_len fixed bin (21); dcl return_arg_ptr ptr; dcl usage char (64); /* Local Constants */ dcl COM_USAGE char (64) internal static options (constant) init ("Usage: nr {}"); dcl AF_USAGE char (64) internal static options (constant) init ("Usage: [nr {}]"); /* External Constants */ dcl error_table_$fatal_error fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$not_act_fnc fixed bin (35) ext static; dcl iox_$user_input ptr ext static; dcl iox_$user_output ptr ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /* External Entries */ dcl active_fnc_err_ entry options (variable); dcl com_err_ entry () options (variable); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); dcl define_area_ entry (ptr, fixed bin (35)); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned); dcl net_info_table_$get_nasp_name entry (char (*), char (*), fixed bin (35)); dcl release_area_ entry (ptr); /* Builtin Functions and Conditions */ dcl addr builtin; dcl null builtin; dcl rtrim builtin; dcl cleanup condition; /* Include Files */ %include nasp_entry_dcls; %include area_info; command_name = "network_request"; in_iocbp = iox_$user_input; out_iocbp = iox_$user_output; queued_flag = "0"b; /* This is an interactive request. */ nasp_area_ptr = null (); /* This sets auto_area_info.areap too. */ nasp_structure_ptr = null (); nasp_structure_len = 0; call cu_$af_return_arg (number_of_args, return_arg_ptr, return_arg_len, code); if code = 0 then do; /* An active function call. */ report_error = active_fnc_err_; get_argument = cu_$af_arg_ptr; usage = AF_USAGE; end; else if code = error_table_$not_act_fnc then do; /* A command call. */ return_arg_ptr = null (); report_error = com_err_; get_argument = cu_$arg_ptr; usage = COM_USAGE; end; else do; /* An error. */ return_arg_ptr = null (); report_error = com_err_; call ERROR (code, "Trying to get the command arguments."); end; if number_of_args < 1 then call ERROR (error_table_$noarg, "^/^a.", usage); arg_idx = 1; /* Process the function argument. */ call get_argument (arg_idx, arg_ptr, arg_len, code); if code ^= 0 then call ERROR (code, "Trying to get the argument."); function_name = arg; call net_info_table_$get_nasp_name (function_name, nasp_name, code); if code ^= 0 then call ERROR (code, "Trying to get the NASP name for the function: ^a.", function_name); NASP_parser = cv_entry_ (rtrim (nasp_name) || "$parser", null (), code); if code ^= 0 then call ERROR (code, "Trying to generate the NASP_$parser entry."); NASP_execute = cv_entry_ (rtrim (nasp_name) || "$execute", null (), code); if code ^= 0 then call ERROR (code, "Trying to generate the NASP_$execute entry."); /* Set up so the NASP entry can get its arguments from our argument list. */ arg_idx = arg_idx + 1; call cu_$arg_list_ptr (arg_list_ptr); on cleanup call Cleanup_Handler (); /* Get a temporary area */ auto_area_info.version = area_info_version_1; auto_area_info.control = "0"b; auto_area_info.control.extend = "1"b; auto_area_info.control.zero_on_alloc = "1"b; auto_area_info.owner = command_name; auto_area_info.size = sys_info$max_seg_size; call define_area_ (addr (auto_area_info), code); if code ^= 0 then call ERROR (code, "Trying to define a temporary area."); /* Do the real work by calling the NASP entries. */ call NASP_parser (in_iocbp, out_iocbp, command_name, arg_list_ptr, arg_idx, queued_flag, nasp_area_ptr, nasp_structure_ptr, nasp_structure_len, nasp_error_message, code); if code ^= 0 then call ERROR (code, "From ^a$parser: ^a", nasp_name, nasp_error_message); call NASP_execute (in_iocbp, out_iocbp, command_name, queued_flag, nasp_structure_ptr, nasp_structure_len, nasp_complete, nasp_unhold, nasp_error_message, code); if code ^= 0 then call ERROR (code, "From ^a$execute: ^a", nasp_name, nasp_error_message); /* nasp_complete and nasp_unhold are ignored for an interactive request, so we are done. */ call Cleanup_Handler (); if return_arg_ptr ^= null () then return_arg = "true"; RETURN: return; /*****************************************************************************/ /* */ /* PROCEDURE: ERROR */ /* */ /* This subroutine expects arguments as follows: */ /* */ /* call ERROR (code, ioa_control_string, ioa_arguments, ...) */ /* */ /* where: code is fixed bin (35), and ioa_control_string and ioa_arguments */ /* are optional character strings as defined for ioa_. */ /* */ /* Some global variables are used: */ /* */ /* Cleanup_Handler (a procedure that does cleanup) */ /* */ /* For commands: */ /* report_error (an entry variable set to com_err_ or active_fnc_err_)*/ /* command_name (the character string name of the command) */ /* return_arg_ptr (used to return "false" for active functions) */ /* */ /* For subroutines: */ /* depends on the error reporting strategy chosen. */ /* */ /* At completion a non-local goto is done to the label RETURN. */ /* */ /* Declarations are expected for: */ /* */ /* cu_$arg_list_ptr */ /* cu_$arg_ptr */ /* cu_$arg_count */ /* error_table_$fatal_error */ /* ioa_$general_rs */ /* */ /*****************************************************************************/ ERROR: proc () options (variable, non_quick); dcl arg_list_ptr ptr; dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl based_code fixed bin (35) based; dcl caller_code fixed bin (35); dcl code fixed bin (35); dcl err_msg char (256); dcl err_msg_len fixed bin (21); dcl nargs fixed bin; call cu_$arg_count (nargs, code); /* IGNORE CODE */ if nargs >= 1 then do; /* We were called correctly. */ arg_ptr = null (); /* Set this so we know if cu_$arg_ptr worked. */ call cu_$arg_ptr (1, arg_ptr, arg_len, code); if arg_ptr ^= null () then caller_code = arg_ptr -> based_code; /* The normal case. */ else caller_code = error_table_$fatal_error; /* Some problem with our arg list. */ if nargs > 1 then do; /* There is a message. */ call cu_$arg_list_ptr (arg_list_ptr); call ioa_$general_rs (arg_list_ptr, 2, 3, err_msg, err_msg_len, "1"b, "0"b); end; else do; /* No message. */ err_msg = ""; err_msg_len = 0; end; end; /* We were called correctly. */ else do; /* We were called with no arguments. */ caller_code = error_table_$fatal_error; /* The best we can do. */ err_msg = ""; err_msg_len = 0; end; /* We were called with no arguments. */ call Cleanup_Handler (); /* The following lines must be modified depending on the error reporting strategy used. */ call report_error (caller_code, command_name, "^a", err_msg); if return_arg_ptr ^= null () then return_arg = "false"; /* Do a non-local goto back to the outermost block. */ goto RETURN; end ERROR; Cleanup_Handler: proc (); if nasp_area_ptr ^= null () then do; if nasp_structure_ptr ^= null () then free nasp_structure in (nasp_area_ptr -> based_area); call release_area_ (nasp_area_ptr); end; return; end Cleanup_Handler; end network_request;  rbf_.pl1 10/17/88 1107.4r w 10/17/88 1033.4 421812 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /*****************************************************************************/ /* */ /* DESCRIPTION: */ /* */ /* This IO module is analogous to g115_. It handles remote batch to */ /* a Level 6M Satellite over an X.25 connection in the same way that g115_ */ /* does remote batch over an RCI connection. It uses tty_ to do its IO. */ /* The four possible devices which are supported, reader, punch, printer, */ /* and teleprinter, all use the same communications channel, therefore, */ /* the channel name can not contain stars. */ /* */ /*****************************************************************************/ /****^ HISTORY COMMENTS: 1) change(82-06-01,RKissel), approve(), audit(), install(): Written. 2) change(87-03-17,LJAdams), approve(87-04-03,MCR7646), audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030): Changed ttd_version to ttd_version_3. END HISTORY COMMENTS */ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */ rbf_: proc (); ERROR_EXIT: return; /* Parameter */ dcl a_buffer_len fixed bin (21) parameter; dcl a_bufferp ptr parameter; dcl a_code fixed bin (35) parameter; dcl a_comerr_sw bit (1) parameter; dcl a_infop ptr parameter; dcl a_iocbp ptr parameter; dcl a_new_modes char (*) parameter; dcl a_old_modes char (*) parameter; dcl a_open_mode fixed bin parameter; dcl a_option (*) char (*) var parameter; dcl a_order char (*) parameter; dcl a_record_len fixed bin (21) parameter; dcl a_recordp ptr parameter; /* Automatic */ dcl 1 auto_area_info aligned like area_info; dcl 1 auto_ttd aligned like terminal_type_data; dcl based_area area (sys_info$max_seg_size) based (areap); dcl bcd_equiv (0:63) char (1) unal defined (bcd_equiv_string); dcl code fixed bin (35); dcl comerr_sw bit (1); dcl dummy_arg char (32); dcl i fixed bin; dcl input_trp ptr; dcl iocbp ptr; dcl mask bit (36) aligned; dcl next_attach_description char (256) varying unaligned; dcl next_attach_options char (256) varying unaligned; dcl next_channel char (32) varying unaligned; dcl next_io_module char (32) varying unaligned; dcl next_io_switch_name char (32) varying unaligned; dcl open_mode fixed bin; dcl output_chars_to_write fixed bin (21); dcl output_trp ptr; dcl my_attach_description char (256) var; dcl slew_by_count_char (0:15) char (1) unaligned defined (legal_slew_chars) pos (2); dcl temp_ptr ptr; /* Structure to define per-attachment data for each rbf_ switch attachment. */ dcl radp ptr; dcl 1 rbf_attach_data based (radp), 2 attach_description char (256) var, 2 open_description char (256) var, 2 modes char (256) var, 2 translations, /* translation tables */ 3 input char (512), 3 output char (512), 2 terminal_type char (32), 2 device char (32), /* name of generic type of remote device */ 2 device_type fixed bin, /* generic device in fixed bin form */ 2 comm_data_ptr ptr; /* common data for this attachment. */ /* Structure for holding communication line specific data for all attachments to this line. */ dcl cdbp ptr; /* pointer to the comm data block. */ dcl 1 comm_data_block aligned based (cdbp), 2 forward_ptr ptr, /* Forward data block chain. */ 2 backward_ptr ptr, /* Backward data block chain. */ 2 comm_channel char (32) unaligned, /* Name of the channel for this RBF station. */ 2 comm_io_module char (32) unaligned, /* Name of the IO module to use. */ 2 comm_iocbp ptr, /* iocb ptr for this RBF station. */ 2 comm_event_channel fixed bin (71), /* event channel used by the IO module. */ 2 timer_event_channel fixed bin (71), /* event channel for use by runout control. */ 2 temp_seg_ptrs (2) ptr, /* 1 is input buffer, 2 is output buffer */ 2 temp_seg_lens (2) fixed bin (21), 2 number_of_attachments fixed bin, 2 input_chars_read fixed bin (21), 2 input_buffer_position fixed bin (21), 2 flags aligned, 3 comm_attached bit (1) unaligned, 3 comm_open bit (1) unaligned, 3 we_just_wrote bit (1) unaligned, 3 pad bit (33) unaligned; dcl input_buffer char (input_buffer_len) based (input_buffer_ptr); dcl input_buffer_ptr ptr defined (comm_data_block.temp_seg_ptrs (1)); dcl input_buffer_len fixed bin (21) defined (comm_data_block.temp_seg_lens (1)); dcl output_buffer char (output_buffer_len) based (output_buffer_ptr); dcl output_buffer_ptr ptr defined (comm_data_block.temp_seg_ptrs (2)); dcl output_buffer_len fixed bin (21) defined (comm_data_block.temp_seg_lens (2)); /* Builtin Functions and Conditions */ dcl addr builtin; dcl bin builtin; dcl codeptr builtin; dcl collate9 builtin; dcl copy builtin; dcl currentsize builtin; dcl dimension builtin; dcl divide builtin; dcl hbound builtin; dcl index builtin; dcl lbound builtin; dcl length builtin; dcl null builtin; dcl rtrim builtin; dcl substr builtin; dcl translate builtin; dcl unspec builtin; dcl verify builtin; dcl any_other condition; dcl cleanup condition; /* Internal Static */ dcl areap ptr int static init (null); dcl debug_flag bit (1) int static init ("0"b); dcl first_cdbp ptr internal static init (null ()); dcl last_cdbp ptr internal static init (null ()); /* Internal Constants */ dcl bcd_equiv_string char (64) unal int static options (constant) init ("0123456789[#@:>? ABCDEFGHI&.](<\^JKLMNOPQR-$*);'+/STUVWXYZ_,%=""!"); dcl CR char (1) internal static options (constant) init (" "); dcl default_modes char (14) init ("8bit,rawi,rawo") int static options (constant); dcl device_names (4) char (32) int static options (constant) init ("teleprinter", "reader", "printer", "punch"); dcl legal_slew_chars char (19) int static options (constant) init (" 0123456789[#@:>?AB"); /* printer slew codes, in order: Top of form - space slew 0 to 15 lines - 0...? VFU_1 - A, VFU_2 - B */ dcl lowercase char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl MY_NAME char (4) int static options (constant) init ("rbf_"); dcl REL_SECONDS bit (2) int static options (constant) init ("11"b); dcl space char (1) int static options (constant) init (" "); dcl uppercase char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); /* The following are RBF specific constants. */ dcl 1 RBF aligned internal static options (constant), /* This group defines input/output media codes associated with records within the text of a message block */ 2 media_codes unal, 3 bcd_input_mc char (1) init ("H"), /* Input media code for BCD data - 110 octal */ 3 bin_input_mc char (1) init ("P"), /* Input media code for Binary data - 120 octal */ 3 printer_mc char (1) init ("L"), /* printer output media code - 114 octal */ 3 punch_bcd_mc char (1) init ("O"), /* punch output media code (BCD data) - 117 octal */ 3 punch_bin_mc char (1) init ("W"), /* punch output media code (Binary data) - 127 octal */ 3 teleprinter_mc char (1) init ("N"), /* teleprinter output media code - 116 octal */ /* This group defines the message format codes which apply to all records in a single message block */ 2 format_codes unal, 3 info_ns_nc bit (9) init ("110"b3),/* information message, no split, no compression */ 3 info_ns_c bit (9) init ("111"b3),/* information message, no split, compression */ 3 info_s_nc bit (9) init ("112"b3),/* information message, split, no compression */ 3 info_s_c bit (9) init ("113"b3),/* information message, split, compression */ 3 special_nc bit (9) init ("104"b3),/* Special control record, no compression */ 3 special_c bit (9) init ("105"b3),/* Special control record, compression */ /* This group defines reserved characters which appear in the message block */ 2 char_codes unal, 3 stx_char bit (9) init ("002"b3),/* start-of-text (STX) char */ 3 etx_char bit (9) init ("003"b3),/* end-of-text (ETX) char */ 3 soh_char bit (9) init ("001"b3),/* start-of-header (SOH) char */ 3 addr_code_char bit (9) init ("100"b3),/* address code character */ 3 id_code_char bit (9) init ("100"b3),/* identification code character */ 3 RS char (1) init (""), /* record separator - 036 octal */ 3 CC char (1) init (""), /* compression character code - 037 octal */ /* The maximum size of a single rci message from SOH to ETX */ 2 max_msg_len fixed bin init (324); /* max data in a message */ /* External Entries */ dcl com_err_ entry () options (variable); dcl continue_to_signal_ entry (fixed bin (35)); dcl convert_ipc_code_ entry (fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); dcl l6_tran_util_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl l6_tran_util_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl mode_string_$parse entry (char (*), ptr, ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)); dcl timer_manager_$reset_alarm_wakeup entry (fixed bin (71)); dcl ttt_info_$terminal_data entry (char (*), fixed bin, fixed bin, ptr, fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* External Constants */ dcl error_table_$bad_mode fixed bin (35) ext static; dcl error_table_$bad_mode_value fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$eof_record fixed bin (35) ext static; dcl error_table_$improper_data_format fixed bin (35) ext static; dcl error_table_$invalid_read fixed bin (35) ext static; dcl error_table_$long_record fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$not_attached fixed bin (35) ext static; dcl error_table_$not_closed fixed bin (35) ext static; dcl error_table_$not_detached fixed bin (35) ext static; dcl error_table_$not_open fixed bin (35) ext static; dcl error_table_$null_info_ptr fixed bin (35) ext static; dcl error_table_$short_record fixed bin (35) ext static; dcl error_table_$smallarg fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; rbf_attach: entry (a_iocbp, a_option, a_comerr_sw, a_code); comerr_sw = debug_flag | a_comerr_sw; iocbp = a_iocbp; /* See if we are already attached. */ if iocbp -> iocb.attach_descrip_ptr ^= null then do; a_code = error_table_$not_detached; return; end; /* Get an area to work in if we don't already have one. */ if areap = null () then areap = get_system_free_area_ (); /* Make a quick consistency check, must have: -tty arg -comm arg -device arg. */ if hbound (a_option, 1) < 6 then call Abort_Attach (error_table_$wrong_no_of_args, MY_NAME, "Invalid attach description", ""); /* Initialize for the cleanup handler. */ next_io_module = ""; next_channel = ""; next_attach_options = ""; my_attach_description = ""; cdbp = null (); radp = null (); on cleanup call Attach_Cleanup (); /* Allocate a structure to hold our attach data, and initialize it. */ allocate rbf_attach_data in (based_area) set (radp); rbf_attach_data.attach_description = ""; rbf_attach_data.open_description = ""; rbf_attach_data.modes = default_modes; rbf_attach_data.translations = ""; rbf_attach_data.terminal_type = ""; rbf_attach_data.device = ""; rbf_attach_data.device_type = 0; rbf_attach_data.comm_data_ptr = null (); /* Process the attachment arguments. */ my_attach_description = MY_NAME; do i = 1 to hbound (a_option, 1); my_attach_description = my_attach_description || space || a_option (i); if a_option (i) = "-device" then rbf_attach_data.device = Get_Option_Arg (i); else if a_option (i) = "-tty" then next_channel = Get_Option_Arg (i); else if a_option (i) = "-comm" then next_io_module = Get_Option_Arg (i); else if a_option (i) = "-ascii" then ; else if a_option (i) = "-ebcdic" then ; else if a_option (i) = "-physical_line_length" | a_option (i) = "-pll" then dummy_arg = Get_Option_Arg (i); else if a_option (i) = "-delay" then dummy_arg = Get_Option_Arg (i); else if a_option (i) = "-terminal_type" | a_option (i) = "-ttp" then rbf_attach_data.terminal_type = Get_Option_Arg (i); else next_attach_options = next_attach_options || space || a_option (i); end; /* do i = ... */ /* Make some checks on the arguments. */ if next_io_module ^= "tty_" then call Abort_Attach (0, MY_NAME, "Invalid or missing -comm option", ""); if next_channel = "" then call Abort_Attach (0, MY_NAME, "No -tty option given", ""); do i = lbound (device_names, 1) to hbound (device_names, 1) while (rbf_attach_data.device ^= device_names (i)); end; if i > hbound (device_names, 1) then call Abort_Attach (error_table_$badopt, MY_NAME, "Invalid device specified", ""); else rbf_attach_data.device_type = i; /* Get translation information and then set input and output translation. */ if rbf_attach_data.terminal_type ^= "" then do; rbf_attach_data.terminal_type = translate (rbf_attach_data.terminal_type, uppercase, lowercase); auto_ttd.version = ttd_version_3; call ttt_info_$terminal_data (rbf_attach_data.terminal_type, -1, 0, addr (auto_ttd), code); if code ^= 0 then call Abort_Attach (code, MY_NAME, "Unknown terminal type specified", ""); input_trp = auto_ttd.tables.input_tr_ptr; output_trp = auto_ttd.tables.output_tr_ptr; end; else do; input_trp = null (); output_trp = null (); end; call Set_Translation (rbf_attach_data.translations.input, input_trp); call Set_Translation (rbf_attach_data.translations.output, output_trp); /* Now see if we already know about the target channel. */ do temp_ptr = first_cdbp repeat (temp_ptr -> comm_data_block.forward_ptr) while (temp_ptr ^= null () & cdbp = null ()); if temp_ptr -> comm_data_block.comm_channel = next_channel then cdbp = temp_ptr; end; /* See if we found a comm_data_block, if not create and initialize one. */ if cdbp = null () then do; allocate comm_data_block in (based_area) set (cdbp); comm_data_block.forward_ptr = null (); comm_data_block.backward_ptr = last_cdbp; comm_data_block.comm_channel = next_channel; comm_data_block.comm_io_module = next_io_module; comm_data_block.comm_iocbp = null (); comm_data_block.comm_event_channel = 0; comm_data_block.timer_event_channel = 0; comm_data_block.temp_seg_ptrs (*) = null (); /* Input and output buffers. */ comm_data_block.temp_seg_lens (*) = sys_info$max_seg_size; comm_data_block.number_of_attachments = 0; comm_data_block.input_chars_read = 0; comm_data_block.input_buffer_position = 1; comm_data_block.flags = "0"b; /*** Get temp segments for the input and output buffers. */ call get_temp_segments_ (MY_NAME, comm_data_block.temp_seg_ptrs, code); if code ^= 0 then call Abort_Attach (code, MY_NAME, "Unable to get input and output buffers", ""); /*** Get an event channel for use by the timer used by the runout control order. */ call ipc_$create_ev_chn (comm_data_block.timer_event_channel, code); if code ^= 0 then do; call convert_ipc_code_ (code); call Abort_Attach (code, MY_NAME, "Unable to get a timer event channel during attachment.", ""); end; /*** Link it into the chain of comm_data_blocks. */ if first_cdbp = null () then first_cdbp = cdbp; else last_cdbp -> comm_data_block.forward_ptr = cdbp; last_cdbp = cdbp; end; /* Finish setting up our attach description data. */ rbf_attach_data.comm_data_ptr = cdbp; /* If necessary, attach and open the communications IO module we will use. */ if ^comm_data_block.flags.comm_attached then do; /* We need to attach. */ next_io_switch_name = MY_NAME || "." || unique_chars_ (""b); next_attach_description = next_io_module || space || next_channel || space || next_attach_options; call iox_$attach_name ((next_io_switch_name), comm_data_block.comm_iocbp, (next_attach_description), codeptr (rbf_attach), code); if code ^= 0 then call Abort_Attach (code, MY_NAME, "Unable to attach communications channel", ""); comm_data_block.flags.comm_attached = "1"b; comm_data_block.flags.comm_open = "0"b; end; /* We need to attach. */ if ^comm_data_block.flags.comm_open then do; /* We need to open. */ call iox_$open (comm_data_block.comm_iocbp, Stream_input_output, "0"b, code); if code ^= 0 then call Abort_Attach (code, MY_NAME, "Unable to open the communications switch.", ""); /*** Set initial modes. */ call iox_$modes (comm_data_block.comm_iocbp, default_modes, (""), code); if code ^= 0 then call Abort_Attach (code, MY_NAME, "Unable to set initial modes on the communications switch.", ""); /*** Get the event channel used by the comm module. */ call iox_$control (comm_data_block.comm_iocbp, "get_event_channel", addr (comm_data_block.comm_event_channel), code); if code ^= 0 then call Abort_Attach (code, MY_NAME, "Unable to get the event channel for the communications switch.", ""); comm_data_block.flags.comm_open = "1"b; end; /* We need to open. */ /* Remember that we have attached a device to this channel. */ comm_data_block.number_of_attachments = comm_data_block.number_of_attachments + 1; /* Make changes to iocb. */ mask = "0"b; on any_other call Any_Other_Handler (); call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.attach_descrip_ptr = addr (rbf_attach_data.attach_description); iocbp -> iocb.attach_data_ptr = radp; iocbp -> iocb.open = rbf_open; iocbp -> iocb.detach_iocb = rbf_detach_iocb; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; rbf_detach_iocb: entry (a_iocbp, a_code); a_code = 0; iocbp = a_iocbp; /* Make sure that switch is closed and attached. */ if iocbp -> iocb.attach_descrip_ptr = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr ^= null then do; a_code = error_table_$not_closed; return; end; radp = iocbp -> iocb.attach_data_ptr; cdbp = rbf_attach_data.comm_data_ptr; /* Remove this device from the communications data. */ comm_data_block.number_of_attachments = comm_data_block.number_of_attachments - 1; call Attach_Cleanup (); /* Get rid of everything we should. */ mask = "0"b; on any_other call Any_Other_Handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> attach_descrip_ptr = null; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; rbf_open: entry (a_iocbp, a_open_mode, a_comerr_sw, a_code); a_code = 0; iocbp = a_iocbp -> iocb.actual_iocb_ptr; /* Make sure that switch is attached and closed. */ if iocbp -> iocb.attach_descrip_ptr = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr ^= null then do; a_code = error_table_$not_closed; return; end; radp = iocbp -> iocb.attach_data_ptr; /* Check opening modes. */ open_mode = a_open_mode; if ^((open_mode = Sequential_input) | (open_mode = Sequential_output) | (open_mode = Sequential_input_output)) then do; a_code = error_table_$bad_mode; return; end; rbf_attach_data.open_description = rtrim (iox_modes (open_mode)); mask = "0"b; on any_other call Any_Other_Handler; call hcs_$set_ips_mask ("0"b, mask); if open_mode = Sequential_input | open_mode = Sequential_input_output then iocbp -> iocb.read_record = rbf_read_record; if open_mode = Sequential_output | open_mode = Sequential_input_output then iocbp -> iocb.write_record = rbf_write_record; iocbp -> iocb.control = rbf_control; iocbp -> iocb.modes = rbf_modes; iocbp -> iocb.close = rbf_close; iocbp -> iocb.detach_iocb = rbf_detach_iocb; iocbp -> iocb.open_descrip_ptr = addr (rbf_attach_data.open_description); call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; rbf_close: entry (a_iocbp, a_code); a_code = 0; iocbp = a_iocbp -> iocb.actual_iocb_ptr; /* Make sure that switch is attached and open. */ if iocbp -> iocb.attach_descrip_ptr = null () then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; mask = "0"b; on any_other call Any_Other_Handler; call hcs_$set_ips_mask ("0"b, mask); iocbp -> iocb.open_descrip_ptr = null; iocbp -> iocb.open = rbf_open; iocbp -> iocb.detach_iocb = rbf_detach_iocb; iocbp -> iocb.control = iox_$err_no_operation; iocbp -> iocb.modes = iox_$err_no_operation; iocbp -> iocb.read_record = iox_$err_no_operation; iocbp -> iocb.write_record = iox_$err_no_operation; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, mask); revert any_other; return; rbf_read_record: entry (a_iocbp, a_bufferp, a_buffer_len, a_record_len, a_code); dcl compression_count fixed bin; dcl current_char char (1); dcl end_of_record bit (1); dcl error_code fixed bin (35); dcl read_record_state fixed bin; dcl user_buffer_len fixed bin (21); iocbp = a_iocbp -> iocb.actual_iocb_ptr; a_record_len = 0; a_code = 0; radp = iocbp -> iocb.attach_data_ptr; cdbp = rbf_attach_data.comm_data_ptr; if rbf_attach_data.device_type ^= TELEPRINTER_DEVICE & rbf_attach_data.device_type ^= READER_DEVICE then do; /* can't read from all devices */ a_code = error_table_$invalid_read; return; end; /* Validate that there is room in the buffer to hold some actual data in addition to a terminal_io_record header. */ terminal_io_record_ptr = a_bufferp; user_buffer_len = a_buffer_len - divide (length (unspec (terminal_io_record.header)), 9, 21); if user_buffer_len <= 0 then do; a_code = error_table_$smallarg; return; end; terminal_io_record_data_chars_varying_max_len = user_buffer_len; /* Initialize the return structure. */ terminal_io_record.version = terminal_io_record_version_1; terminal_io_record.device_type = 0; terminal_io_record.slew_type = SLEW_BY_COUNT; terminal_io_record.slew_count = 1; terminal_io_record.flags = "0"b; terminal_io_record.element_size = 9; terminal_io_record.n_elements = 0; /* Initially the null string. */ /* Check to see if we have to tell the L6 that he can send, this is also done in the read_status order. */ if comm_data_block.flags.we_just_wrote then do; /* Tell him he can send. */ call Check_Write_Status (code); if code ^= 0 then goto READ_ERROR; call Send_EOM (code); if code ^= 0 then goto READ_ERROR; call Check_Write_Status (code); if code ^= 0 then goto READ_ERROR; comm_data_block.flags.we_just_wrote = "0"b; end; /* Tell him he can send. */ /* Read in the record, one character at a time since there may be compressed text. */ read_record_state = 1; error_code = 0; end_of_record = "0"b; do while (^end_of_record); if comm_data_block.input_buffer_position > comm_data_block.input_chars_read then do; /* We need some more data. */ call l6_tran_util_$get_chars (comm_data_block.comm_iocbp, input_buffer_ptr, input_buffer_len, comm_data_block.input_chars_read, code); if code ^= error_table_$short_record & code ^= 0 then goto READ_ERROR; comm_data_block.input_buffer_position = 1; end; /* We need some more data. */ current_char = substr (input_buffer, comm_data_block.input_buffer_position, 1); goto RECORD_PARSER (read_record_state); RECORD_PARSER (1): /* Handle the media code. */ if current_char = RBF.media_codes.bcd_input_mc then terminal_io_record.device_type = READER_DEVICE; else if current_char = RBF.media_codes.bin_input_mc then do; terminal_io_record.device_type = READER_DEVICE; terminal_io_record.flags.binary = "1"b; end; else if current_char = RBF.media_codes.teleprinter_mc then terminal_io_record.device_type = TELEPRINTER_DEVICE; else do; /* Not an input record but read it anyway. */ terminal_io_record.device_type = 0; error_code = error_table_$improper_data_format; end; comm_data_block.input_buffer_position = comm_data_block.input_buffer_position + 1; read_record_state = 2; goto NEXT_STATE; RECORD_PARSER (2): /* Handle normal char, compression char, or EOR char. */ if current_char = RBF.char_codes.CC then read_record_state = 3; /* Decompress the previous char. */ else if current_char = RBF.char_codes.RS then end_of_record = "1"b; /* We are done. */ else do; /* A normal character. */ if length (terminal_io_record_data_chars_varying) < user_buffer_len then terminal_io_record_data_chars_varying = terminal_io_record_data_chars_varying || current_char; else error_code = error_table_$long_record; /* Must throw it away. */ read_record_state = 2; end; comm_data_block.input_buffer_position = comm_data_block.input_buffer_position + 1; goto NEXT_STATE; RECORD_PARSER (3): /* Handle the compression count character. */ compression_count = index (bcd_equiv_string, current_char); if compression_count <= 1 then do; /* Min is 2, max is 63. */ if current_char < substr (bcd_equiv_string, 2, 1) then compression_count = 2; else compression_count = 63; end; if user_buffer_len - length (terminal_io_record_data_chars_varying) < compression_count then do; /* Not enough room in the user buffer. */ error_code = error_table_$long_record; compression_count = user_buffer_len - length (terminal_io_record_data_chars_varying); if compression_count <= 0 then compression_count = 0; end; terminal_io_record_data_chars_varying = terminal_io_record_data_chars_varying || copy ( substr (terminal_io_record_data_chars_varying, length (terminal_io_record_data_chars_varying), 1), compression_count); comm_data_block.input_buffer_position = comm_data_block.input_buffer_position + 1; read_record_state = 2; goto NEXT_STATE; NEXT_STATE: end; /* Loop through the record. */ /* Finally, do the translation and we are done. */ terminal_io_record_data_chars_varying = translate (terminal_io_record_data_chars_varying, rbf_attach_data.translations.input, collate9 ()); /* Check for a $*$ card, and if it is one, then give back a zero length record. */ if length (terminal_io_record_data_chars_varying) >= 3 then if substr (terminal_io_record_data_chars_varying, 1, 3) = "$*$" then terminal_io_record.n_elements = 0; /* Check for an end of file record from the card reader and return the right code. */ if terminal_io_record_data_chars_varying = "++EOF" | terminal_io_record_data_chars_varying = "++eof" then error_code = error_table_$eof_record; a_record_len = 4 * currentsize (terminal_io_record); a_code = error_code; return; READ_ERROR: a_code = code; return; rbf_write_record: entry (a_iocbp, a_recordp, a_record_len, a_code); dcl media_code char (1); dcl rep_count fixed bin; dcl slew_char char (1); dcl slew_count fixed bin (18); iocbp = a_iocbp -> iocb.actual_iocb_ptr; a_code = 0; radp = iocbp -> iocb.attach_data_ptr; cdbp = rbf_attach_data.comm_data_ptr; terminal_io_record_ptr = a_recordp; /* Check arguments for inconsistencies. */ if terminal_io_record.version ^= terminal_io_record_version_1 then do; a_code = error_table_$unimplemented_version; return; end; if terminal_io_record.preslew then do; a_code = error_table_$improper_data_format; return; end; /* Set media code and slew character. */ slew_count = 0; if terminal_io_record.device_type = TELEPRINTER_DEVICE then do; media_code = RBF.media_codes.teleprinter_mc; slew_char = CR; end; else if terminal_io_record.device_type = PRINTER_DEVICE then do; media_code = RBF.media_codes.printer_mc; if terminal_io_record.slew_type = SLEW_BY_COUNT then do; slew_count = terminal_io_record.slew_count; if slew_count < lbound (slew_by_count_char, 1) then do; a_code = error_table_$improper_data_format; return; end; if slew_count > hbound (slew_by_count_char, 1) then do; slew_char = slew_by_count_char (hbound (slew_by_count_char, 1)); /* Do the most we can. */ slew_count = slew_count - hbound (slew_by_count_char, 1); /* Figure what is left. */ end; else do; slew_char = slew_by_count_char (slew_count); slew_count = 0; /* Nothing left. */ end; end; else if terminal_io_record.slew_type = SLEW_TO_TOP_OF_PAGE then slew_char = space; else if terminal_io_record.slew_type = SLEW_TO_INSIDE_PAGE then slew_char = space; else if terminal_io_record.slew_type = SLEW_TO_OUTSIDE_PAGE then slew_char = space; else if terminal_io_record.slew_type = SLEW_TO_CHANNEL then slew_char = space; else slew_char = "1"; /* All undefined slew types default to this */ end; else if terminal_io_record.device_type = PUNCH_DEVICE then do; if terminal_io_record.flags.binary then media_code = RBF.media_codes.punch_bin_mc; else media_code = RBF.media_codes.punch_bcd_mc; end; else media_code = ""; /* If the data is binary, turn it into 6 bit chunks, otherwise, translate it. */ if (terminal_io_record.binary & terminal_io_record.element_size ^= 1) | (^terminal_io_record.binary & terminal_io_record.element_size ^= 9) then do; a_code = error_table_$improper_data_format; return; end; if terminal_io_record.binary then do; terminal_io_record.n_elements = divide (terminal_io_record.n_elements + 5, 6, 18); terminal_io_record.element_size = 6; substr (output_buffer, 1, 1) = media_code; do i = 1 to terminal_io_record.n_elements; substr (output_buffer, i + 1, 1) = bcd_equiv (bin (terminal_io_record.data.bits (i), 6)); end; end; else do; substr (output_buffer, 1, 1) = media_code; substr (output_buffer, 2, terminal_io_record.n_elements) = translate (terminal_io_record_data_chars, rbf_attach_data.translations.output, collate9 ()); end; output_chars_to_write = terminal_io_record.n_elements + 1; /* Add the media_code length. */ /* Perform data compression (except on teleprinter output). */ if rbf_attach_data.device_type ^= TELEPRINTER_DEVICE then do; i = 2; do while (i <= output_chars_to_write); /* Do this since we may modify the counters. */ rep_count = verify (substr (output_buffer, i, output_chars_to_write - i + 1), substr (output_buffer, i, 1)) - 1; if rep_count < 0 then rep_count = output_chars_to_write - i + 1; /* everything matched. */ if rep_count > 64 then rep_count = 64; /* This is the limit. */ if rep_count <= 3 then i = i + 1; /* no compression needed. */ else do; /* compress this one. */ substr (output_buffer, i + 1, 1) = RBF.char_codes.CC; substr (output_buffer, i + 2, 1) = bcd_equiv (rep_count - 1); i = i + 3; output_chars_to_write = output_chars_to_write - rep_count + 3; substr (output_buffer, i, output_chars_to_write - i + 1) = substr (output_buffer, i + rep_count - 3, output_chars_to_write - i + 1); /* Shift the end of the data over the compressed chars. */ end; end; /* Compression loop. */ end; /* Perform data compression. */ /* Now add slew control if necessary, and add the final record separator character. */ if media_code = RBF.media_codes.printer_mc | media_code = RBF.media_codes.teleprinter_mc then do; /* Handle devices that slew. */ substr (output_buffer, output_chars_to_write + 1, 2) = slew_char || RBF.char_codes.RS; output_chars_to_write = output_chars_to_write + 2; if slew_count > 0 then do; /* Send null records to finish slewing. */ do while (slew_count > hbound (slew_by_count_char, 1)); substr (output_buffer, output_chars_to_write + 1, 3) = media_code || slew_by_count_char (hbound (slew_by_count_char, 1)) || RBF.char_codes.RS; output_chars_to_write = output_chars_to_write + 3; slew_count = slew_count - hbound (slew_by_count_char, 1); end; if slew_count > 0 then do; /* Get the last bit. */ substr (output_buffer, output_chars_to_write + 1, 3) = media_code || slew_by_count_char (slew_count) || RBF.char_codes.RS; output_chars_to_write = output_chars_to_write + 3; end; end; /* Send null records to finish slewing. */ end; /* Handle devices that slew. */ else do; substr (output_buffer, output_chars_to_write + 1, 1) = RBF.char_codes.RS; output_chars_to_write = output_chars_to_write + 1; end; /* Transmit record to comm_io_module io switch. */ call l6_tran_util_$put_chars (comm_data_block.comm_iocbp, output_buffer_ptr, output_chars_to_write, a_code); /* Set a flag so the control and read_record entries can send the $*$EOM record. */ if rbf_attach_data.device_type = TELEPRINTER_DEVICE then comm_data_block.flags.we_just_wrote = "1"b; return; rbf_control: entry (a_iocbp, a_order, a_infop, a_code); a_code = 0; iocbp = a_iocbp -> iocb.actual_iocb_ptr; /* Make sure the switch is attached and open. */ if iocbp -> iocb.attach_descrip_ptr = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; radp = iocbp -> iocb.attach_data_ptr; cdbp = rbf_attach_data.comm_data_ptr; if a_order = "end_write_mode" then do; /* Handle end_write_mode. */ call Check_Write_Status (code); if code ^= 0 then goto CONTROL_ERROR; call Send_EOM (code); if code ^= 0 then goto CONTROL_ERROR; call Check_Write_Status (code); if code ^= 0 then goto CONTROL_ERROR; end; /* Handle end_write_mode. */ else if a_order = "runout" then do; /* Handle runout. */ call Check_Write_Status (code); if code ^= 0 then goto CONTROL_ERROR; end; /* Handle runout. */ else if a_order = "read_status" then do; /* Handle read_status. */ tty_read_status_info_ptr = a_infop; if tty_read_status_info_ptr = null () then do; a_code = error_table_$null_info_ptr; return; end; if comm_data_block.flags.we_just_wrote then do; /* Tell him he can send. */ call Check_Write_Status (code); if code ^= 0 then goto CONTROL_ERROR; call Send_EOM (code); if code ^= 0 then goto CONTROL_ERROR; call Check_Write_Status (code); if code ^= 0 then goto CONTROL_ERROR; comm_data_block.flags.we_just_wrote = "0"b; end; /* Tell him he can send. */ /* We will assume that if we have any input then it is at least one record, even if it is only a $*$ card. The same is true if tty_ has some input that we have'nt read yet. Therefore, if we have any input, then our caller will not go blocked if he calls read_record. If we don't then tty_ will return the right results. That is, if it has some input, then we won't go blocked when we try to read a complete record, and if it does not have input, then it will send a wakeup when it gets some. */ if comm_data_block.input_buffer_position <= comm_data_block.input_chars_read then tty_read_status_info.input_pending = "1"b; else tty_read_status_info.input_pending = "0"b; /*** If we have input then just get the event channel else let tty_ do the work. */ if tty_read_status_info.input_pending then call iox_$control (comm_data_block.comm_iocbp, "get_event_channel", addr (tty_read_status_info.event_channel), a_code); else call iox_$control (comm_data_block.comm_iocbp, "read_status", a_infop, a_code); end; /* Handle read_status. */ else if a_order = "select_device" | a_order = "reset" | a_order = "binary_punch" then ; /* Ignore, done by magic in terminal_io_record. */ /* Pass all other control orders on to the communications switch. */ else call iox_$control (comm_data_block.comm_iocbp, a_order, a_infop, a_code); return; CONTROL_ERROR: a_code = code; return; rbf_modes: entry (a_iocbp, a_new_modes, a_old_modes, a_code); a_code = 0; a_old_modes = ""; iocbp = a_iocbp -> iocb.actual_iocb_ptr; /* Make sure the switch is attached and open. */ if iocbp -> iocb.attach_descrip_ptr = null then do; a_code = error_table_$not_attached; return; end; if iocbp -> iocb.open_descrip_ptr = null then do; a_code = error_table_$not_open; return; end; radp = iocbp -> iocb.attach_data_ptr; call mode_string_$parse (a_new_modes, areap, mode_string_info_ptr, a_code); if a_code ^= 0 then return; if mode_string_info.version ^= mode_string_info_version_2 then do; a_code = error_table_$unimplemented_version; return; end; do i = lbound (mode_string_info.modes, 1) to hbound (mode_string_info.modes, 1); if mode_string_info.modes (i).mode_name = "rawi" | mode_string_info.modes (i).mode_name = "rawo" | mode_string_info.modes (i).mode_name = "8bit" then do; if ^(mode_string_info.modes (i).boolean_valuep & mode_string_info.modes (i).boolean_value) then do; a_code = error_table_$bad_mode_value; return; end; end; else do; a_code = error_table_$bad_mode; return; end; end; a_old_modes = rbf_attach_data.modes; rbf_attach_data.modes = a_new_modes; return; /* Internal routines */ Get_Option_Arg: proc (idx) returns (char (*) var); dcl idx fixed bin parameter; idx = idx + 1; if idx > hbound (a_option, 1) then call Abort_Attach (error_table_$noarg, MY_NAME, "No argument after ^a", (a_option (idx - 1))); my_attach_description = my_attach_description || space || a_option (idx); return (a_option (idx)); end Get_Option_Arg; Any_Other_Handler: proc (); if mask then call hcs_$reset_ips_mask (mask, mask); mask = "0"b; call continue_to_signal_ ((0)); end Any_Other_Handler; Attach_Cleanup: proc (); dcl code fixed bin (35); if radp ^= null then free rbf_attach_data in (based_area); if cdbp ^= null () then do; if comm_data_block.number_of_attachments = 0 then do; if input_buffer_ptr ^= null () | output_buffer_ptr ^= null () then call release_temp_segments_ (MY_NAME, comm_data_block.temp_seg_ptrs, code); if comm_data_block.comm_iocbp ^= null () then do; call iox_$close (comm_data_block.comm_iocbp, code); call iox_$detach_iocb (comm_data_block.comm_iocbp, code); call iox_$destroy_iocb (comm_data_block.comm_iocbp, code); end; if comm_data_block.timer_event_channel ^= 0 then call ipc_$delete_ev_chn (comm_data_block.timer_event_channel, code); call Free_Comm_Data_Block (); end; end; return; end Attach_Cleanup; Abort_Attach: proc (code, prog_name, control_str, arg_value); dcl code fixed bin (35) parameter; dcl prog_name char (*) parameter; dcl control_str char (*) parameter; dcl arg_value char (*) parameter; call Attach_Cleanup; call Abort (code, prog_name, control_str, arg_value); end Abort_Attach; Abort: proc (code, prog_name, control_str, arg_value); dcl code fixed bin (35) parameter; dcl prog_name char (*) parameter; dcl control_str char (*) parameter; dcl arg_value char (*) parameter; if comerr_sw then call com_err_ (code, prog_name, control_str, arg_value); a_code = code; go to ERROR_EXIT; end Abort; Check_Write_Status: proc (code); /* This routine checks the write_status and loops until the write is complete. The timer is needed since write_status does not guarantee to send a wakeup if output_pending is set. */ dcl code fixed bin (35) parameter; dcl 1 event_info aligned, 2 channel_id fixed bin (71), 2 message fixed bin (71), 2 sender bit (36), 2 origin, 3 dev_signal bit (18) unaligned, 3 ring bit (18) unaligned, 2 channel_index fixed bin; dcl 1 wait_list aligned, 2 nchan fixed bin, 2 pad fixed bin, 2 channel_id (2) fixed bin (71); dcl 1 write_status_info aligned, 2 ev_chan fixed bin (71), 2 output_pending bit (1); /* Set up a wait list for blocking in write_status. */ wait_list.nchan = 2; wait_list.pad = 0; wait_list.channel_id (1) = comm_data_block.comm_event_channel; wait_list.channel_id (2) = comm_data_block.timer_event_channel; call iox_$control (comm_data_block.comm_iocbp, "write_status", addr (write_status_info), code); if code ^= 0 then return; do while (write_status_info.output_pending & write_status_info.ev_chan ^= 0); call timer_manager_$alarm_wakeup (1, REL_SECONDS, comm_data_block.timer_event_channel); call ipc_$block (addr (wait_list), addr (event_info), code); if code ^= 0 then do; call convert_ipc_code_ (code); return; end; call timer_manager_$reset_alarm_wakeup (comm_data_block.timer_event_channel); call ipc_$drain_chn (comm_data_block.timer_event_channel, code); if code ^= 0 then do; call convert_ipc_code_ (code); return; end; call iox_$control (comm_data_block.comm_iocbp, "write_status", addr (write_status_info), code); if code ^= 0 then return; end; /* Write status loop. */ return; end Check_Write_Status; Free_Comm_Data_Block: proc (); /* Unlinks and frees what cdbp points to. */ if comm_data_block.backward_ptr = null () then first_cdbp = comm_data_block.forward_ptr; /* It was the head of the chain. */ else comm_data_block.backward_ptr -> comm_data_block.forward_ptr = comm_data_block.forward_ptr; if comm_data_block.forward_ptr = null () then last_cdbp = comm_data_block.backward_ptr; /* It was the tail of the chain. */ else comm_data_block.forward_ptr -> comm_data_block.backward_ptr = comm_data_block.backward_ptr; free comm_data_block in (based_area); cdbp = null (); return; end Free_Comm_Data_Block; Send_EOM: proc (P_code); dcl P_code fixed bin (35) parameter; output_chars_to_write = length ("$*$EOM" || RBF.char_codes.RS); substr (output_buffer, 1, output_chars_to_write) = "$*$EOM" || RBF.char_codes.RS; call l6_tran_util_$put_chars (comm_data_block.comm_iocbp, output_buffer_ptr, output_chars_to_write, P_code); return; end Send_EOM; Set_Translation: proc (translate_table, trans_strucp); dcl translate_table char (512) parameter; dcl trans_strucp ptr parameter; dcl translate_string_len fixed bin (21); dcl translate_stringp ptr; dcl translate_string char (translate_string_len) based (translate_stringp); if trans_strucp = null then translate_table = collate9 (); else do; translate_stringp = addr (trans_strucp -> cv_trans_struc.cv_trans.value); translate_string_len = dimension (trans_strucp -> cv_trans_struc.cv_trans.value, 1); translate_table = translate_string; if length (translate_table) > translate_string_len then substr (translate_table, translate_string_len + 1) = copy ("", length (translate_table) - translate_string_len); end; return; end Set_Translation; %include iox_dcls; %include iocb; %include iox_modes; %include mode_string_info; %include area_info; %include terminal_type_data; %include tty_convert; %include tty_read_status_info; %include terminal_io_record; debug_on: entry (); debug_flag = "1"b; return; debug_off: entry (); debug_flag = "0"b; return; end rbf_; 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