PNOTICE_transfer.alm 11/18/82 1707.3rew 11/18/82 1630.1 5643 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** dec 1 "version 1 structure dec 1 "no. of pnotices dec 3 "no. of STIs dec 100 "lgth of all pnotices + no. of pnotices acc "Copyright (c) 1972 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc." aci "W1FTSM090000" aci "W2FTSM090000" aci "W3FTSM090000" end  l6_ftf.pl1 11/18/82 1707.3rew 11/18/82 1628.4 138627 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indend,initlm3,dclind5,idind32 */ l6_ftf: proc (); /* D_E_S_C_R_I_P_T_I_O_N_ This command sets up a file transfer server on the specified channel that talks Level 6 FTF protocol. It continues listening to the channel until the user types "q" or "quit". J_O_U_R_N_A_L_I_Z_A_T_I_O_N_ 1) Written 6/79 by R.J.C. Kissel. */ dcl cu_$af_arg_count entry (fixed bin, fixed bin (35)); dcl nargs fixed bin; dcl code fixed bin (35); dcl com_err_ entry options (variable); dcl com_name char (6) internal static options (constant) init ("l6_ftf"); dcl error_table_$wrong_no_of_args fixed bin (35) external; dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl argp ptr; dcl argl fixed bin (21); dcl arg char (argl) based (argp); dcl channel_name char (32); dcl error_table_$bigarg fixed bin (35) external; dcl length builtin; dcl dial_manager_$privileged_attach entry (ptr, fixed bin (35)); dcl 1 dial_manager_arg aligned, 2 version fixed bin, 2 dial_qualifier char (22), 2 dial_channel fixed bin (71), 2 channel_name char (32); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl dial_event_chn fixed bin (71); dcl convert_ipc_code_ entry (fixed bin (35)); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl l6_switch_ptr ptr; dcl null builtin; dcl error_table_$not_detached fixed bin (35) external; dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl error_table_$not_closed fixed bin (35) external; dcl iox_$user_input ptr external; dcl user_input_ptr ptr; dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl 1 read_status_info aligned, 2 event_chn fixed bin (71), 2 input_available bit (1); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl iobp ptr; dcl io_buf char (sys_info$max_seg_size * 4) based aligned; dcl sys_info$max_seg_size fixed bin (19) external; dcl user_event_chn fixed bin (71); dcl l6_event_chn fixed bin (71); dcl l6_input_rdy bit (1); dcl 1 wait_list aligned, 2 nchan fixed bin, 2 pad fixed bin, 2 channel_id (3) fixed bin (71); 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_idx fixed bin; dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl cleanup condition; dcl l6_ftf_switch char (13) internal static options (constant) init ("l6_ftf_switch"); dcl user_output_ptr ptr; dcl error_output_ptr ptr; dcl iox_$user_output ptr external; dcl iox_$error_output ptr external; dcl dialed bit (1); dcl l6_attached bit (1); dcl l6_open bit (1); dcl iobl fixed bin (21); dcl error_table_$not_act_fnc fixed bin (35) external; dcl arg_idx fixed bin; dcl long_flag bit (1); dcl error_flag bit (1); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl user_input_rdy bit (1); dcl user_done bit (1); dcl error_table_$badopt fixed bin (35) external; dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl dial_manager_$release_channel entry (ptr, fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl l6_ftf_ entry (ptr, ptr, fixed bin (21), ptr, bit (1), ptr, bit (1), char (168), fixed bin (35)); dcl addr builtin; dcl substr builtin; dcl error_table_$noarg fixed bin (35) external; dcl target_dir char (168); dcl get_wdir_ entry () returns (char (168)); /* Initialize everything for cleanup. */ user_input_ptr = iox_$user_input; user_output_ptr = iox_$user_output; error_output_ptr = iox_$error_output; dial_channel = 0; dialed = "0"b; l6_attached = "0"b; l6_open = "0"b; iobp = null (); iobl = 0; long_flag = "0"b; target_dir = get_wdir_ (); channel_name = ""; on cleanup call Cleanup_Handler (); /* Processs the command arguments. */ call cu_$af_arg_count (nargs, code); if code ^= error_table_$not_act_fnc then goto ERROR_actfncall; if nargs > 4 | nargs < 1 then goto ERROR_wrongargs; do arg_idx = 1 to nargs by 1; call cu_$arg_ptr (arg_idx, argp, argl, code); if code ^= 0 then goto ERROR_arg; if substr (arg, 1, 1) = "-" then do; /* Process a control argument. */ if arg = "-long" | arg = "-lg" then long_flag = "1"b; else if arg = "-target_dir" | arg = "-td" then do; arg_idx = arg_idx + 1; if arg_idx > nargs then goto ERROR_missarg; call cu_$arg_ptr (arg_idx, argp, argl, code); if code ^= 0 then goto ERROR_arg; target_dir = arg; if target_dir = ">" then target_dir = ""; /* Special case the root. */ end; else goto ERROR_controlarg; end; else do; /* Process the channel name. */ if argl > length (channel_name) then goto ERROR_longchn; channel_name = arg; end; end; if channel_name = "" then goto ERROR_wrongargs; /* This _m_u_s_t be specified. */ /* Now create an event channel for dial_manager_ to use and make the call to get the specified channel attached. At this point we will get the user input event channel and an IO buffer and then block waiting for either a dialup wakeup or some input from the user. */ call ipc_$create_ev_chn (dial_event_chn, code); if code ^= 0 then goto ERROR_createchn; dial_manager_arg.version = 1; dial_manager_arg.dial_qualifier = ""; dial_manager_arg.dial_channel = dial_event_chn; dial_manager_arg.channel_name = channel_name; call dial_manager_$privileged_attach (addr (dial_manager_arg), code); if code ^= 0 then dialed = "1"b; /* Assume it is already dialed. */ else dialed = "0"b; call iox_$control (user_input_ptr, "read_status", addr (read_status_info), code); if code ^= 0 then goto ERROR_userstatus; user_event_chn = read_status_info.event_chn; user_input_rdy = read_status_info.input_available; wait_list.nchan = 2; wait_list.pad = 0; wait_list.channel_id (1) = user_event_chn; wait_list.channel_id (2) = dial_event_chn; event_info.channel_id = 0; /* Initialize this for the first time through the loop. */ call get_temp_segment_ (com_name, iobp, code); if code ^= 0 then goto ERROR_getseg; do while (^dialed); if user_input_rdy then do; call Process_User_Input (user_done); if user_done then goto DONE; call iox_$control (user_input_ptr, "read_status", addr (read_status_info), code); if code ^= 0 then goto ERROR_userstatus; user_input_rdy = read_status_info.input_available; end; else if event_info.channel_id = dial_event_chn then dialed = "1"b; else do; call ipc_$block (addr (wait_list), addr (event_info), code); if code ^= 0 then goto ERROR_block; if user_event_chn = event_info.channel_id then do; call iox_$control (user_input_ptr, "read_status", addr (read_status_info), code); if code ^= 0 then goto ERROR_userstatus; user_input_rdy = read_status_info.input_available; end; end; end; /* Attach, open, and set the modes for the Level 6 channel, and get a temp segment to use as an IO buffer. */ call iox_$attach_name (l6_ftf_switch, l6_switch_ptr, "tty_ " || channel_name, null (), code); if code ^= 0 & code ^= error_table_$not_detached then goto ERROR_l6attach; l6_attached = "1"b; /* Set this for use by cleanup. */ call iox_$open (l6_switch_ptr, 3, "0"b, code); /* For stream_input_output. */ if code ^= 0 & code ^= error_table_$not_closed then goto ERROR_l6open; l6_open = "1"b; /* Set this for use by cleanup. */ call iox_$modes (l6_switch_ptr, "rawi,rawo", "", code); if code ^= 0 then goto ERROR_modes; /* Read status on both the L6 and user switches in order to initialize the variables to be used in the transfer loop. */ call iox_$control (user_input_ptr, "read_status", addr (read_status_info), code); if code ^= 0 then goto ERROR_userstatus; user_input_rdy = read_status_info.input_available; call iox_$control (l6_switch_ptr, "read_status", addr (read_status_info), code); if code ^= 0 then goto ERROR_l6status; l6_event_chn = read_status_info.event_chn; l6_input_rdy = read_status_info.input_available; wait_list.nchan = 3; wait_list.pad = 0; wait_list.channel_id (1) = user_event_chn; wait_list.channel_id (2) = l6_event_chn; wait_list.channel_id (3) = dial_event_chn; error_flag = "1"b; /* Allow l6_ftf_ to print on error_output. */ /* This loop runs until the user types quit or q on his terminal. */ do while ("1"b); /* Exit when user says he is done. */ /* This loop checks the input ready flags for both the L6 switch and the user switch and processes any input it finds. It continues until no input is available on either switch at which point we block on both switches, waiting for input. */ do while (l6_input_rdy | user_input_rdy); if l6_input_rdy then do; call l6_ftf_ (l6_switch_ptr, iobp, length (iobp -> io_buf), user_output_ptr, long_flag, error_output_ptr, error_flag, target_dir, code); /* Any messages have already been printed. */ if code ^= 0 then call iox_$control (l6_switch_ptr, "abort", null (), code); if code ^= 0 then call com_err_ (code, com_name, "Failed to abort L6 channel, continuing processing."); call iox_$control (l6_switch_ptr, "read_status", addr (read_status_info), code); if code ^= 0 then goto ERROR_l6status; l6_input_rdy = read_status_info.input_available; end; if user_input_rdy then do; call Process_User_Input (user_done); if user_done then goto DONE; /* Exit the outermost do loop. */ call iox_$control (user_input_ptr, "read_status", addr (read_status_info), code); if code ^= 0 then goto ERROR_userstatus; user_input_rdy = read_status_info.input_available; end; end; /* Block here. When we wake up, verify that the switch which caused the wakeup actually has input available and then reenter the input processing loop. */ call ipc_$block (addr (wait_list), addr (event_info), code); if code ^= 0 then goto ERROR_block; if l6_event_chn = event_info.channel_id then do; call iox_$control (l6_switch_ptr, "read_status", addr (read_status_info), code); if code ^= 0 then goto ERROR_l6status; l6_input_rdy = read_status_info.input_available; end; else if user_event_chn = event_info.channel_id then do; call iox_$control (user_input_ptr, "read_status", addr (read_status_info), code); if code ^= 0 then goto ERROR_userstatus; user_input_rdy = read_status_info.input_available; end; else if dial_event_chn = event_info.channel_id then goto ERROR_hangup; else goto ERROR_fatal; /* Not an event channel we know about. */ end; DONE: call Cleanup_Handler (); return; ERROR_actfncall: if code = 0 then call com_err_ (0, com_name, "May not be called as an active function."); else call com_err_ (code, com_name); goto DONE; ERROR_wrongargs: call com_err_ (error_table_$wrong_no_of_args, com_name, "Usage: ^a channel_name {-long, -lg } {-target_dir path, -td path}", com_name); goto DONE; ERROR_arg: call com_err_ (code, com_name, "Accessing argument ^d.", arg_idx); goto DONE; ERROR_controlarg: call com_err_ (error_table_$badopt, com_name, "^a", arg); goto DONE; ERROR_longchn: call com_err_ (error_table_$bigarg, com_name, "^a", arg); goto DONE; ERROR_createchn: call convert_ipc_code_ (code); call com_err_ (code, com_name, "Creating event channel for dial_manager_ to use."); goto DONE; ERROR_l6attach: call com_err_ (code, com_name, "Attaching ^a to tty_ through ^a.", channel_name, l6_ftf_switch); goto DONE; ERROR_l6open: call com_err_ (code, com_name, "Opening ^a.", l6_ftf_switch); goto DONE; ERROR_modes: call com_err_ (code, com_name, "Setting rawi and rawo on ^a.", l6_ftf_switch); goto DONE; ERROR_getseg: call com_err_ (code, com_name, "Getting IO buffer segment."); goto DONE; ERROR_userstatus: call com_err_ (code, com_name, "Reading status of user input."); goto DONE; ERROR_l6status: call com_err_ (code, com_name, "Reading status of ^a.", l6_ftf_switch); goto DONE; ERROR_block: call convert_ipc_code_ (code); call com_err_ (code, com_name, "Waiting for input."); goto DONE; ERROR_fatal: call com_err_ (0, com_name, "Wakeup on unknown event channel ^o, from process ^.3b", event_info.channel_id, event_info.sender); goto DONE; ERROR_missarg: call com_err_ (error_table_$noarg, com_name, "For the ^a control argument.", arg); goto DONE; ERROR_hangup: call com_err_ (0, com_name, "Hangup signalled on ^a.", l6_ftf_switch); goto DONE; Process_User_Input: proc (finished); dcl finished bit (1); dcl n_read fixed bin (21); call iox_$get_line (user_input_ptr, iobp, length (iobp -> io_buf), n_read, code); if n_read <= 1 then do; call ioa_ ("You may type quit or q to exit this invocation of ^a.", com_name); finished = "0"b; end; else if substr (iobp -> io_buf, 1, n_read - 1) = "quit" | substr (iobp -> io_buf, 1, n_read - 1) = "q" then finished = "1"b; else do; call ioa_ ("You may type quit or q to exit this invocation of ^a.", com_name); finished = "0"b; end; end Process_User_Input; Cleanup_Handler: proc (); /* Notice that these if statements must be kept in their current order. */ if l6_open then call iox_$close (l6_switch_ptr, code); if l6_attached then call iox_$detach_iocb (l6_switch_ptr, code); if dialed then call dial_manager_$release_channel (addr (dial_manager_arg), code); if dial_event_chn ^= 0 then call ipc_$delete_ev_chn (dial_channel, code); if iobp ^= null () then call release_temp_segment_ (com_name, iobp, code); end Cleanup_Handler; end l6_ftf;  l6_ftf_.pl1 11/18/82 1707.3rew 11/18/82 1628.6 382995 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /*(stringsize, stringrange): DEBUG*/ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indend,initlm3,dclind5,idind32 */ l6_ftf_: proc (Pl6swp, Piobp, Piobl, Puop, Puof, Peop, Peof, Ptdir, Pcode); /*dcl ioa_ entry options(variable); DEBUG*/ dcl ( Pl6swp ptr, /* Input -- Pointer to iocb for Level 6 communication. */ Piobp ptr, /* Input -- Pointer to an IO buffer. */ Piobl fixed bin (21), /* Input -- Length of the IO buffer if Piobp is non-null. */ Puop ptr, /* Input -- Pointer to an iocb for user output. */ Puof bit (1), /* Input -- Flag controlling user output. */ Peop ptr, /* Input -- Pointer to an iocb for error output. */ Peof bit (1), /* Input -- Flag controlling error output. */ Ptdir char (168), /* Input -- Pathname of directory where transfers happen. */ Pcode fixed bin (35) /* Output -- Standard system error code. */ ) parameter; /* D_E_S_C_R_I_P_T_I_O_N_ This subroutine takes a pointer to an iocb opened for stream_input_output to a Level 6 and an IO buffer pointer and length in characters, and implements the Level 6 FTF protocol to transfer a single file to or from the Level 6. The IO buffer is used for receiving input from, and sending output to the Level 6 as defined by the protocol. The other arguments are a pointer to an iocb for writing information to the user and a flag controlling this output; and a pointer to an iocb for writing error messages and a flag controlling this. Fianlly, a standard system status code is returned indicating the success or failure of the file transfer. If no IO buffer pointer is provided then a temp segment will be used and released for each invocation of this subroutine. If the user and/or error output flags are off, the corresponding pointers may be null and no output will be done. J_O_U_R_N_A_L_I_Z_A_T_I_O_N_ 1) Written 6/79 by R.J.C. Kissel. */ dcl iobp ptr; /* Pointer to the IO buffer. */ dcl cleanup condition; dcl l6_switchp ptr; /* Pointer to Level 6 iocb. */ dcl user_switchp ptr; /* Pointer to user output iocb. */ dcl error_switchp ptr; /* Pointer to error output iocb. */ dcl user_flag bit (1); /* ON -- Output information to the user. */ dcl error_flag bit (1); /* ON -- Output error messages to the user. */ dcl tseg_allocated bit (1); /* ON -- Indicates we allocated a temp segment. */ dcl sub_name char (7) internal static options (constant) init ("l6_ftf_"); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl code fixed bin (35); /* Returned status code. */ dcl iobl fixed bin (21); /* Length of the IO buffer. */ dcl sys_info$max_seg_size fixed bin (19) external; dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl io_buf_array (iobl) char (1) based unaligned; dcl io_buf char (iobl) based unaligned; dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl length builtin; dcl null builtin; dcl substr builtin; dcl target_dir char (168); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl 1 file_info, 2 iox_info, 3 file_ptr ptr, 3 attached bit (1), 3 open bit (1), 3 mode fixed bin, /* Either stream or record. */ 2 direction fixed bin, 2 name char (168), 2 type fixed bin, 2 data_type fixed bin, 2 rec_size fixed bin (21), 2 starting_rec fixed bin (21), 2 access fixed bin, 2 key_len fixed bin, 2 key_off fixed bin, 2 percent_fill fixed bin, 2 key_type fixed bin, 2 ci_size fixed bin, 2 size fixed bin (21), 2 init_file_count fixed bin, 2 accept_file_count fixed bin; dcl 1 binary_data aligned based, 2 num_sextets fixed bin (35) aligned, 2 sextets (0 refer (binary_data.num_sextets)) fixed bin (6) unsigned unaligned; dcl Cstream fixed bin internal static options (constant) init (1); dcl Crecord fixed bin internal static options (constant) init (2); dcl Cinput fixed bin internal static options (constant) init (1); dcl Coutput fixed bin internal static options (constant) init (2); dcl Cnew fixed bin internal static options (constant) init (1); dcl Cold fixed bin internal static options (constant) init (2); dcl Cascii fixed bin internal static options (constant) init (1); dcl Cbinary fixed bin internal static options (constant) init (2); dcl Cbcd fixed bin internal static options (constant) init (3); dcl Csequential fixed bin internal static options (constant) init (1); dcl Crelative fixed bin internal static options (constant) init (2); dcl Cindexed fixed bin internal static options (constant) init (3); dcl Cuninitialized fixed bin internal static options (constant) init (0); dcl message_ptr ptr; dcl message_len fixed bin (21); dcl message char (message_len) based (message_ptr); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl l6_file_switch char (14) internal static options (constant) init ("l6_file_switch"); dcl iox_$open entry (ptr, fixed bin, bit (1), fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl mod builtin; dcl rtrim builtin; dcl addr builtin; dcl string builtin; dcl copy builtin; dcl addrel builtin; dcl maxlength builtin; dcl currentsize builtin; dcl min builtin; dcl rank builtin; dcl byte builtin; dcl current_iob_position fixed bin (21); dcl current_iob_length fixed bin (21); dcl current_tusn fixed bin; dcl current_rsn fixed bin; dcl last_successful_rsn fixed bin; dcl global_string char (1024) varying; dcl data_buf char (1024) varying; dcl error_table_$short_record fixed bin (35) external; dcl error_table_$end_of_info fixed bin (35) external; dcl accept_msg char (256); dcl accept_msg_len fixed bin (21); dcl internal_tu char (1000) varying; dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl Cnew_line char (1) internal static options (constant) init (" "); dcl ioa_$ioa_switch entry options (variable); dcl ioa_$ioa_switch_nnl entry options (variable); dcl timer_manager_$alarm_call entry (fixed bin (71), bit (2), entry); dcl timer_manager_$reset_alarm_call entry (entry); dcl read_timeout entry variable; dcl write_timeout entry variable; dcl get_chars_done bit (1); dcl put_chars_done bit (1); dcl timeout_value fixed bin (71); l6_switchp = Pl6swp; user_switchp = Puop; user_flag = Puof; error_switchp = Peop; error_flag = Peof; target_dir = Ptdir; last_successful_rsn = 0; current_rsn = 0; current_tusn = 0; current_iob_position = 0; current_iob_length = 0; global_string = ""; data_buf = ""; internal_tu = "0"; read_timeout = Read_Timeout; write_timeout = Write_Timeout; get_chars_done = "0"b; put_chars_done = "0"b; timeout_value = 2 * 60 * 1000000; /* 2 minutes in microseconds. */ tseg_allocated = "0"b; call Init_File_Info (); on cleanup call Cleanup_Handler (); /* Setup the IO buffer pointer and length. */ if Piobp = null () then do; call get_temp_segment_ (sub_name, iobp, code); if code ^= 0 then call ERROR (code, 0, "Error getting temp segment for io buffer."); tseg_allocated = "1"b; iobl = sys_info$max_seg_size * 4; end; else do; iobp = Piobp; iobl = Piobl; end; /* Do the control phase dialogue with the Level 6. */ call Read (code); if code ^= 0 then call ERROR (code, 0, "Trying to read the first record from the L6."); call Get_Chars (3, message_ptr, message_len, "0"b, code); if code ^= 0 then call ERROR (code, 0, "Looking for ""OK?""."); if message ^= "OK?" then call ERROR (10, 0, "Connection request was not ""OK?"", but: ^a.", message); call Write ("OK", code); if code ^= 0 then call ERROR (code, 0, "Trying to send ""OK""."); call Read (code); if code ^= 0 then call ERROR (code, 0, "Trying to read initiate request."); call Process_Initiate_Request (); call Open_File (); call Make_Accept_Msg (accept_msg, accept_msg_len); call Write (substr (accept_msg, 1, accept_msg_len), code); /* Acceptor's yes answer. */ if code ^= 0 then call ERROR (code, 0, "Trying to send acceptor's yes answer."); /* Do the file transfer as specified in the control phase. */ if file_info.direction = Coutput then call Send_File (); else call Receive_File (); Pcode = 0; RETURN: call Cleanup_Handler (); return; Read: proc (Pcode); dcl Pcode fixed bin (35) parameter; dcl n_read fixed bin (21); dcl code fixed bin (35); get_chars_done = "0"b; if timeout_value > 0 then call timer_manager_$alarm_call (timeout_value, "10"b, read_timeout); /* Relative microseconds. */ call iox_$get_chars (l6_switchp, iobp, iobl, n_read, code); get_chars_done = "1"b; /* Narrow an already small window. */ if timeout_value > 0 then call timer_manager_$reset_alarm_call (read_timeout); /*call ioa_("read : ""^a"", ^d chars.",substr(iobp->io_buf,1,n_read),n_read); DEBUG*/ if code = 0 | code = error_table_$short_record then do; current_iob_length = n_read; current_iob_position = 0; end; else do; current_iob_length = 0; current_iob_position = 0; end; Pcode = code; end Read; Write: proc (Poutput, Pcode); dcl Poutput char (*) parameter; dcl Pcode fixed bin (35) parameter; dcl code fixed bin (35); /*call ioa_("write: ""^a"", ^d chars.",Poutput,length(Poutput)); DEBUG*/ put_chars_done = "0"b; if timeout_value > 0 then call timer_manager_$alarm_call (timeout_value, "10"b, write_timeout); /* Relative microseconds. */ call iox_$put_chars (l6_switchp, addr (Poutput), length (Poutput), code); put_chars_done = "1"b; /* Narrow an already small window. */ if timeout_value > 0 then call timer_manager_$reset_alarm_call (write_timeout); Pcode = code; end Write; Read_Timeout: proc (Pmc_ptr, Pname); dcl Pmc_ptr ptr; dcl Pname char (*); if get_chars_done then return; /* Hit the window. */ call ERROR (720, 2, "Timeout on read from the L6."); end Read_Timeout; Write_Timeout: proc (Pmc_ptr, Pname); dcl Pmc_ptr ptr; dcl Pname char (*); if put_chars_done then return; /* Hit the window. */ call ERROR (721, 0, "Timeout on write to the L6."); end Write_Timeout; ERROR: proc () options (variable, non_quick); dcl based_code fixed bin (35) based; dcl based_action fixed bin based; dcl caller_code fixed bin (35); dcl code fixed bin (35); dcl action fixed bin; dcl arg_list_ptr ptr; dcl nargs fixed bin; dcl err_msg char (256); dcl err_msg_len fixed bin; dcl err_msg_count pic "99"; dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl 1 reject, 2 header char (6) unaligned, 2 err_num pic "zzzzzzzzzz9" unaligned, 2 separator char (2) unaligned, 2 err_msg char (72) unaligned; 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, bit (1), bit (1)); dcl ioa_$rsnpnnl entry options (variable); dcl cu_$arg_count entry (fixed bin); call cu_$arg_list_ptr (arg_list_ptr); call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then goto FATAL; caller_code = arg_ptr -> based_code; call cu_$arg_ptr (2, arg_ptr, arg_len, code); if code ^= 0 then goto FATAL; action = arg_ptr -> based_action; call cu_$arg_count (nargs); if nargs > 2 then call ioa_$general_rs (arg_list_ptr, 3, 4, err_msg, err_msg_len, "0"b, "0"b); else call ioa_$rsnpnnl ("Error number: ^d.", err_msg, err_msg_len, caller_code); if error_flag then call ioa_$ioa_switch (error_switchp, "^/^a Code = ^d.", substr (err_msg, 1, err_msg_len), caller_code); if action = 0 then ; /* All done. */ else if action = 1 then do; /* Send a rejection message. */ reject.header = "8091&'"; reject.err_num = caller_code; reject.separator = ": "; reject.err_msg = substr (err_msg, 1, length (reject.err_msg)); call Write (string (reject), code); end; else if action = 2 then do; /* Send a file transfer error record. */ if err_msg_len > 99 then err_msg_len = 99; err_msg_count = err_msg_len; call Write ("CU" || err_msg_count || substr (err_msg, 1, err_msg_len) || "R", code); end; else goto FATAL; Pcode = caller_code; goto RETURN; FATAL: Pcode = code; goto RETURN; end ERROR; Process_Initiate_Request: proc (); dcl request_length fixed bin; dcl file_name_length fixed bin (21); dcl field_ptr ptr; dcl field_len fixed bin (21); dcl field char (field_len) based (field_ptr); call Get_Chars (1, field_ptr, field_len, "0"b, code); if field ^= " " | code ^= 0 then call ERROR (code, 1, "Character was ""^a"" instead of "" "".", field); call Get_Chars (3, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting initiate request length."); request_length = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric initiate request length: ^a.", field); call Get_Chars (1, field_ptr, field_len, "0"b, code); if field ^= " " | code ^= 0 then call ERROR (code, 1, "Character was ""^a"" instead of "" "".", field); call Get_Chars (1, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting the direction."); if field = "I" then file_info.direction = Coutput; else if field = "O" then file_info.direction = Cinput; else call ERROR (code, 1, "Unknown direction: ^a.", field); call Get_Chars (1, field_ptr, field_len, "0"b, code); if (field ^= "!" & field ^= """") | code ^= 0 then call ERROR (code, 1, "Character was ""^a"" instead of ""!"" or """".", field); call Get_Chars (2, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting name length."); file_name_length = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric name length: ^a.", field); call Get_Chars (file_name_length, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting file name."); file_info.name = field; call Get_Chars (1, field_ptr, field_len, "0"b, code); if code = error_table_$end_of_info then return; /* No attributes to process. */ if field ^= "#" | code ^= 0 then call ERROR (code, 1, "Character was ""^a"" instead of ""#"".", field); do while (code = 0); /* Process the attributes. */ call Get_Chars (1, field_ptr, field_len, "0"b, code); if code = 0 then do; /* Process an attribute indicator. */ if field = "P" then do; call Get_Chars (1, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting file type."); if field = "D" | field = "R" | field = "F" then file_info.type = Crelative; else if field = "S" then file_info.type = Csequential; else if field = "I" then file_info.type = Cindexed; else call ERROR (60, 1, "Unknown file type: ^a.", field); end; else if field = "Q" then do; call Get_Chars (1, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting data type."); if field = "8" then file_info.data_type = Cbinary; else if field = "A" then file_info.data_type = Cascii; else if field = "B" then file_info.data_type = Cbcd; else call ERROR (61, 1, "Unknown data type: ^a.", field); end; else if field = "R" then do; call Get_Chars (4, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting record size."); file_info.rec_size = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric record size: ^a.", field); end; else if field = "S" then do; call Get_Chars (5, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting starting record."); file_info.starting_rec = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric starting record: ^a.", field); end; else if field = "T" then do; call Get_Chars (1, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting file access."); if field = "N" then file_info.access = Cnew; else if field = "O" then file_info.access = Cold; else call ERROR (62, 1, "Unknown file access code: ^a.", field); end; else if field = "U" then do; call Get_Chars (3, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting key length."); file_info.key_len = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric key length: ^a.", field); end; else if field = "V" then do; call Get_Chars (4, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting key offset."); file_info.key_off = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric key offset: ^a.", field); end; else if field = "W" then do; call Get_Chars (2, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting percent fill."); file_info.percent_fill = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric percent fill: ^a.", field); end; else if field = "X" then do; call Get_Chars (1, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting key type."); if field = "8" then file_info.key_type = Cbinary; else if field = "A" then file_info.key_type = Cascii; else if field = "B" then file_info.key_type = Cbcd; else call ERROR (62, 1, "Unknown key type: ^a", field); end; else if field = "Y" then do; call Get_Chars (5, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting ci size."); file_info.ci_size = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric ci size: ^a.", field); end; else if field = "Z" then do; call Get_Chars (5, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting file size."); file_info.size = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric file size: ^a.", field); end; else if field = "[" then do; call Get_Chars (2, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting initiators file count."); file_info.init_file_count = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric initiators file count: ^a.", field); end; else if field = "\" then do; call Get_Chars (2, field_ptr, field_len, "0"b, code); if code ^= 0 then call ERROR (code, 1, "Error getting acceptors file count."); file_info.accept_file_count = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 1, "Non-numeric acceptors file count: ^a.", field); end; else call ERROR (150, 1, "Unrecognized attribute indicator ""^a"".", field); end; /* Process an attribute indicator. */ end; /* Process the attributes. */ end Process_Initiate_Request; Make_Accept_Msg: proc (Pmsg, Pmsglen); dcl Pmsg char (*) parameter; dcl Pmsglen fixed bin (21) parameter; dcl Cfile_type (3) char (1) internal static options (constant) init ("S", "R", "I"); dcl Cdata_type (3) char (1) internal static options (constant) init ("A", "8", "B"); if file_info.direction = Cinput then do; Pmsg = "8005$"; Pmsglen = 5; end; else do; Pmsg = "8010$#P" || Cfile_type (file_info.type) || "Q" || Cdata_type (file_info.data_type); Pmsglen = 10; end; end Make_Accept_Msg; Get_Chars: proc (Pnum, Pptr, Plen, Ptu, Pcode); dcl Pnum fixed bin (21) parameter; dcl Pptr ptr parameter; dcl Plen fixed bin (21) parameter; dcl Ptu bit (1) parameter; dcl Pcode fixed bin (35) parameter; dcl num_left fixed bin (21); dcl num_to_get fixed bin (21); dcl char_ptr ptr; dcl char_len fixed bin (21); dcl char_string char (char_len) based (char_ptr); if current_iob_position + Pnum <= current_iob_length then do; Pptr = addr (iobp -> io_buf_array (current_iob_position + 1)); Plen = Pnum; Pcode = 0; current_iob_position = current_iob_position + Pnum; end; else do; if ^Ptu then do; /* Should have been all in one record. */ Pptr = null (); Plen = 0; Pcode = error_table_$end_of_info; end; else do; /* Data continues in the next transmission unit. */ /* First save what is left in this transmission unit in a global string, but special case when there is nothing left in the current transmission unit (this is also the case the first time when no transmission unit has been gotten). This code assumes that data is never split across more than two transmission units!! */ num_left = current_iob_length - current_iob_position; num_to_get = Pnum - num_left; if num_left ^= 0 then global_string = substr (iobp -> io_buf, current_iob_position + 1, num_left); call Get_Next_Tu (); call Get_Chars (num_to_get, char_ptr, char_len, "0"b, code); if code ^= 0 then call ERROR (code, 2, "Error getting data from TU number: ^d.", current_tusn); if num_left = 0 then do; Pptr = char_ptr; Plen = char_len; Pcode = 0; end; else do; global_string = global_string || char_string; Pptr = addrel (addr (global_string), 1); /* Since global string is varying. */ Plen = length (global_string); Pcode = 0; end; end; end; return; Get_Next_Tu: proc (); dcl code fixed bin (35); dcl ascii_rsn pic "99999"; dcl tusn fixed bin; dcl field_ptr ptr; dcl field_len fixed bin (21); dcl field char (field_len) based (field_ptr); ascii_rsn = last_successful_rsn; call Write ("P" || ascii_rsn, code); if code ^= 0 then call ERROR (code, 2, "Error sending prompt ^a.", "P" || ascii_rsn); call Read (code); if code ^= 0 then call ERROR (code, 2, "Reading transmission unit ^d.", current_tusn + 1); call Get_Chars (1, field_ptr, field_len, "0"b, code); tusn = cv_dec_check_ (field, code); if code ^= 0 then call ERROR (code, 2, "Non-numeric tusn: ^a.", field); if tusn ^= current_tusn then call ERROR (40, "TUSN out of sequence. Expected = ^d, New = ^d.", current_tusn, tusn); current_tusn = mod (current_tusn + 1, 10); end Get_Next_Tu; end Get_Chars; Init_File_Info: proc (); file_info.file_ptr = null (); file_info.attached = "0"b; file_info.open = "0"b; file_info.direction = Cuninitialized; file_info.name = ""; file_info.type = Cuninitialized; file_info.data_type = Cuninitialized; file_info.rec_size = Cuninitialized; file_info.starting_rec = Cuninitialized; file_info.access = Cuninitialized; file_info.key_len = Cuninitialized; file_info.key_off = Cuninitialized; file_info.percent_fill = Cuninitialized; file_info.key_type = Cuninitialized; file_info.ci_size = Cuninitialized; file_info.init_file_count = Cuninitialized; file_info.accept_file_count = Cuninitialized; end Init_File_Info; Open_File: proc (); dcl code fixed bin (35); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl dir_name char (168); dcl entry_name char (32); dcl 1 info like indx_info; /* BEGIN include file: vfs_info.incl.pl1. */ %include vfs_info; /* END include file: vfs_info.incl.pl1. */ dcl vfile_status_ entry (char (*), char (*), ptr, fixed bin (35)); file_info.name = rtrim (target_dir) || ">" || file_info.name; if substr (file_info.name, 1, 2) = ">>" then file_info.name = substr (file_info.name, 2); /* Fix absolute path case. */ if file_info.direction = Coutput then do; call expand_pathname_ (file_info.name, dir_name, entry_name, code); if code ^= 0 then call ERROR (code, 1, "Error expanding pathname: ^a.", file_info.name); info.info_version = vfs_version_1; call vfile_status_ (dir_name, entry_name, addr (info), code); if code ^= 0 then call ERROR (code, 1, "Error getting status of file for output: ^a.", file_info.name); if info.type = 1 then do; /* An unstructured file. */ if file_info.type = Cuninitialized then file_info.type = Csequential; if file_info.data_type = Cuninitialized then file_info.data_type = Cascii; if (file_info.type ^= Csequential) & (file_info.data_type ^= Cascii) then call ERROR (500, 1, "^a is unstructured but L6 requested type = ^d, data_type = ^d.", file_info.name, file_info.type, file_info.data_type); end; else if info.type = 2 then do; /* A sequential file. */ if file_info.type = Cuninitialized then file_info.type = Csequential; if file_info.data_type = Cuninitialized then file_info.data_type = Cbinary; if (file_info.type ^= Csequential) & (file_info.data_type ^= Cbinary) then call ERROR (501, 1, "^a is sequential but L6 requested type = ^d, data_type = ^d.", file_info.name, file_info.type, file_info.data_type); end; else call ERROR (502, 1, "Transfer of file type: ^d, is not implemented.", info.type); end; else do; if file_info.type = Cuninitialized then file_info.type = Csequential; if file_info.data_type = Cuninitialized then file_info.data_type = Cascii; if file_info.key_type = Cuninitialized then file_info.key_type = Cascii; end; if file_info.starting_rec = Cuninitialized then file_info.starting_rec = 0; if file_info.type = Cindexed & (file_info.key_len = Cuninitialized | file_info.key_off = Cuninitialized) then call ERROR (70, 1, "An indexed file was specified without a key length or offset."); call iox_$attach_name (l6_file_switch, file_info.file_ptr, "vfile_ " || file_info.name, null (), code); if code ^= 0 then call ERROR (code, 1, "Error attaching file: ^a.", file_info.name); file_info.attached = "1"b; if file_info.type = Csequential then do; if file_info.data_type = Cascii then do; if file_info.direction = Coutput then call iox_$open (file_info.file_ptr, 1, "0"b, code); /* Stream input */ else call iox_$open (file_info.file_ptr, 2, "0"b, code); /* Stream output */ end; else do; if file_info.direction = Coutput then call iox_$open (file_info.file_ptr, 4, "0"b, code); /* Sequential input */ else call iox_$open (file_info.file_ptr, 5, "0"b, code); /* Sequential output */ end; end; else call ERROR (327, 1, "Relative or indexed files are not supported: ^a.", file_info.name); if code ^= 0 then call ERROR (code, 1, "Opening file: ^a.", file_info.name); file_info.open = "1"b; if file_info.starting_rec > 0 then do; call iox_$position (file_info.file_ptr, 0, file_info.starting_rec, code); if code ^= 0 then call ERROR (code, 1, "Error positioning file: ^a to record ^d.", file_info.name, file_info.starting_rec); end; end Open_File; Receive_File: proc (); dcl code fixed bin (35); dcl eof bit (1); dcl next_char_ptr ptr; dcl next_char_len fixed bin (21); dcl next_char char (next_char_len) based (next_char_ptr); dcl last_prompt pic "99999"; dcl strange_case_char char (1); if user_flag then call ioa_$ioa_switch_nnl (user_switchp, "Transfer of file from L6 to ^a is -- ", file_info.name); eof = "0"b; strange_case_char = ""; do while (^eof); data_buf = ""; if strange_case_char = "" then do; call Get_Chars (1, next_char_ptr, next_char_len, "1"b, code); if code ^= 0 then call ERROR (code, 2, "Getting first character of record ^d.", current_rsn); end; else do; next_char_ptr = addr (strange_case_char); next_char_len = 1; end; if next_char = "8" | next_char = "A" | next_char = "B" then call Data_Record (strange_case_char); else if next_char = "C" then call Control_Record (); else if next_char = "E" then eof = "1"b; else call ERROR (10, 2, "Unexpected media code: ^a in record ^d.", next_char, current_rsn); if ^eof then do; call Write_Record (); last_successful_rsn = current_rsn; current_rsn = current_rsn + 1; end; else do; /* Finish the control phase dialogue. */ last_prompt = last_successful_rsn + 1; call Write ("P" || last_prompt, code); if code ^= 0 then call ERROR (code, 0, "Error writing last prompt ^a.", "P" || last_prompt); end; end; if user_flag then call ioa_$ioa_switch (user_switchp, "completed."); return; Control_Record: proc (); call ERROR (0, 0, substr (iobp -> io_buf, 1, current_iob_length)); end Control_Record; Data_Record: proc (Pchar); dcl Pchar char (1); dcl end_of_record bit (1); call Check_Rsn (); end_of_record = "0"b; Pchar = ""; do while (^end_of_record); call Get_Chars (1, next_char_ptr, next_char_len, "1"b, code); if code ^= 0 then call ERROR (code, 2, "Error getting record segment header character."); if next_char = "U" then call Process_Data ("0"b); else if next_char = "P" then call Process_Data ("1"b); else if next_char = "R" then end_of_record = "1"b; /* Strange, inconsistent stuff. It might be a "E" or an "A" if the previous record ended the TU. */ else do; end_of_record = "1"b; Pchar = next_char; end; end; end Data_Record; Check_Rsn: proc (); dcl ascii_rsn char (ascii_rsn_len) based (ascii_rsn_ptr); dcl ascii_rsn_len fixed bin (21); dcl ascii_rsn_ptr ptr; dcl rsn fixed bin; call Get_Chars (5, ascii_rsn_ptr, ascii_rsn_len, "1"b, code); if code ^= 0 then call ERROR (code, 2, "Error getting record sequence number ^d.", current_rsn); rsn = cv_dec_check_ (ascii_rsn, code); if code ^= 0 then call ERROR (code, 2, "Non-numeric RSN: ^a.", ascii_rsn); if rsn ^= current_rsn then call ERROR (30, 2, "RSN out of sequence. Expected = ^d, New = ^d.", current_rsn, rsn); end Check_Rsn; Process_Data: proc (Ppacked); dcl Ppacked bit (1) parameter; dcl data_ptr ptr; dcl data_len fixed bin (21); dcl data char (data_len) based (data_ptr); dcl data_count_ptr ptr; dcl data_count_len fixed bin (21); dcl data_count char (data_count_len) based (data_count_ptr); dcl count fixed bin (21); call Get_Chars (2, data_count_ptr, data_count_len, "1"b, code); if code ^= 0 then call ERROR (code, 2, "Error getting data count for unpacked data in record: ^d.", current_rsn); count = cv_dec_check_ (data_count, code); if code ^= 0 then call ERROR (code, 2, "Non-numeric unpacked data count: ^a.", data_count); if ^Ppacked then do; call Get_Chars (count, data_ptr, data_len, "1"b, code); if code ^= 0 then call ERROR (code, 2, "Error getting unpacked data for record: ^d.", current_rsn); data_buf = data_buf || data; end; else do; call Get_Chars (1, data_ptr, data_len, "1"b, code); if code ^= 0 then call ERROR (code, 2, "Error getting packed character in record: ^d.", current_rsn); data_buf = data_buf || copy (data, count); end; end Process_Data; Write_Record: proc (); dcl code fixed bin (35); dcl char_idx fixed bin; dcl binary_data_buf (256) bit (36) aligned; dcl bdbp ptr; if file_info.data_type = Cascii & file_info.type = Csequential then do; data_buf = data_buf || Cnew_line; call iox_$put_chars (file_info.file_ptr, addrel (addr (data_buf), 1), length (data_buf), code); end; else if file_info.data_type = Cbinary & file_info.type = Csequential then do; bdbp = addr (binary_data_buf); bdbp -> binary_data.num_sextets = length (data_buf); do char_idx = 1 to bdbp -> binary_data.num_sextets; if substr (data_buf, char_idx, 1) >= " " & substr (data_buf, char_idx, 1) <= "_" then bdbp -> binary_data.sextets (char_idx) = rank (substr (data_buf, char_idx, 1)) - rank (" "); else call ERROR (101, 2, "Invalid character in binary transfer: ^a. char index = ^d, rec no = ^d.", substr (data_buf, char_idx, 1), char_idx, current_rsn); end; call iox_$write_record (file_info.file_ptr, bdbp, currentsize (bdbp -> binary_data) * 4, code); end; else call ERROR (100, 2, "Unsupported data type (^d) or file type (^d).", file_info.data_type, file_info.type); if code ^= 0 then call ERROR (code, 2, "Error writing data in record ^d.", current_rsn); return; end Write_Record; end Receive_File; Send_File: proc (); dcl rec_buf char (1024) aligned; dcl rec_buf_len fixed bin (21); dcl eof bit (1); dcl last_prompt_no pic "99999"; dcl last_prompt_ptr ptr; dcl last_prompt_len fixed bin (21); dcl last_prompt char (last_prompt_len) based (last_prompt_ptr); if user_flag then call ioa_$ioa_switch_nnl (user_switchp, "Transfer of ^a to L6 is -- ", file_info.name); eof = "0"b; do while (^eof); if file_info.type = Csequential then do; if file_info.data_type = Cascii then call iox_$get_line (file_info.file_ptr, addr (rec_buf), length (rec_buf), rec_buf_len, code); else call iox_$read_record (file_info.file_ptr, addr (rec_buf), length (rec_buf), rec_buf_len, code); end; else call ERROR (600, 2, "Blocked or indexed files are not yet supported."); if code = error_table_$end_of_info then eof = "1"b; else if code = 0 then do; call Put_Record (rec_buf, rec_buf_len); current_rsn = current_rsn + 1; end; else call ERROR (code, 2, "Error reading record ^d.", current_rsn); end; call Eof (); last_prompt_no = last_successful_rsn + 1; call Read (code); if code ^= 0 then call ERROR (code, 0, "Error reading last prompt."); call Get_Chars (6, last_prompt_ptr, last_prompt_len, "0"b, code); if code ^= 0 then call ERROR (code, 0, "Error getting last prompt characters."); if last_prompt ^= "P" || last_prompt_no then call ERROR (0b, 0b, "Last prompt, expected ^a, received ^a.", "P" || last_prompt_no, last_prompt); if user_flag then call ioa_$ioa_switch (user_switchp, "completed."); return; Put_Record: proc (Prec, Plen); dcl Prec char (*) aligned parameter; dcl Plen fixed bin (21) parameter; dcl temp_rec char (1024) varying; dcl rsn pic "99999"; dcl rec_segment_len pic "99"; dcl rec_type char (1); dcl split_len fixed bin (21); dcl header char (6); dcl rec_segment_hdr char (3); dcl data_idx fixed bin (21); dcl data_left fixed bin (21); dcl data_count fixed bin (21); dcl left_in_tu fixed bin (21); dcl char_idx fixed bin; if file_info.data_type = Cascii then do; temp_rec = substr (Prec, 1, Plen - 1); /* Get rid of the newline at the end. */ if temp_rec = "" then temp_rec = " "; /* Special case null lines for L6. */ rec_type = "A"; end; else if file_info.data_type = Cbinary then do; /* Turn binary data into characters and continue. */ temp_rec = ""; do char_idx = 1 to addr (Prec) -> binary_data.num_sextets; temp_rec = temp_rec || byte (addr (Prec) -> binary_data.sextets (char_idx) + rank (" ")); end; rec_type = "8"; end; else call ERROR (610, 2, "Record data type ^d is not supported.", file_info.data_type); /* First put in the record header, assuming it will split, substr takes care of everything. */ rsn = current_rsn; header = rec_type || rsn; left_in_tu = maxlength (internal_tu) - length (internal_tu); split_len = min (left_in_tu, length (header)); internal_tu = internal_tu || substr (header, 1, split_len); left_in_tu = left_in_tu - split_len; if left_in_tu = 0 then do; call Send_Tu (); left_in_tu = maxlength (internal_tu) - length (internal_tu); end; internal_tu = internal_tu || substr (header, split_len + 1); /* May be the null string. */ left_in_tu = left_in_tu - (length (header) - split_len); /* The header is in, now loop for each record segment, consisting of "U" || count || data, where count is 2 characters. */ data_count = length (temp_rec); data_idx = 1; data_left = length (temp_rec); do while (data_left > 0); if left_in_tu > 3 then do; data_count = min (left_in_tu - 3, 99, data_left); rec_segment_len = data_count; /* Convert to characters. */ internal_tu = internal_tu || "U" || rec_segment_len || substr (temp_rec, data_idx, data_count); data_idx = data_idx + data_count; data_left = data_left - data_count; left_in_tu = left_in_tu - 3 - data_count; end; else do; data_count = min (99, data_left); rec_segment_len = data_count; rec_segment_hdr = "U" || rec_segment_len; split_len = left_in_tu; internal_tu = internal_tu || substr (rec_segment_hdr, 1, split_len); /* That filled the tu. */ call Send_Tu (); left_in_tu = maxlength (internal_tu) - length (internal_tu); internal_tu = internal_tu || substr (rec_segment_hdr, split_len + 1) || substr (temp_rec, data_idx, data_count); data_idx = data_idx + data_count; data_left = data_left - data_count; left_in_tu = left_in_tu - (length (rec_segment_hdr) - split_len) - data_count; end; end; /* do */ if left_in_tu > 0 then internal_tu = internal_tu || "R"; else do; call Send_Tu (); internal_tu = internal_tu || "R"; end; return; Eof: entry (); if maxlength (internal_tu) = length (internal_tu) then call Send_Tu (); internal_tu = internal_tu || "E"; call Send_Tu (); return; Send_Tu: proc (); dcl prompt_ptr ptr; dcl prompt_len fixed bin (21); dcl prompt char (prompt_len) based (prompt_ptr); dcl rsn fixed bin; dcl tusn pic "9"; dcl tu char (length (internal_tu)) based (addrel (addr (internal_tu), 1)); call Read (code); if code ^= 0 then call ERROR (code, 2, "Error getting prompt from L6."); call Get_Chars (6, prompt_ptr, prompt_len, "0"b, code); if code ^= 0 then call ERROR (code, 2, "Error getting prompt characters."); if substr (prompt, 1, 1) = "P" then do; rsn = cv_dec_check_ (substr (prompt, 2, 5), code); if code ^= 0 then call ERROR (code, 2, "Non-numeric rsn in prompt: ^a.", prompt); if rsn ^= last_successful_rsn & rsn ^= last_successful_rsn + 1 /* Special case for split records. */ then call ERROR (655, 2, "Records out of sequence. Prompt was ^d, Expected ^d.", rsn, last_successful_rsn); call Write (tu, code); if code ^= 0 then call ERROR (code, 2, "Error writing tu: ^d, with record: ^d.", current_tusn, current_rsn); last_successful_rsn = current_rsn - 1; current_tusn = mod (current_tusn + 1, 10); tusn = current_tusn; internal_tu = tusn; end; else if substr (prompt, 1, 1) = "C" then call ERROR (0, 0, substr (iobp -> io_buf, 1, current_iob_length)); else call ERROR (653, 2, "First character of prompt was ""^a"" instead of ""P"".", substr (prompt, 1, 1)); end Send_Tu; end Put_Record; end Send_File; Cleanup_Handler: proc (); dcl code fixed bin (35); if tseg_allocated then call release_temp_segment_ (sub_name, iobp, code); if file_info.file_ptr ^= null () then do; call iox_$close (file_info.file_ptr, code); call iox_$detach_iocb (file_info.file_ptr, code); end; call timer_manager_$reset_alarm_call (read_timeout); call timer_manager_$reset_alarm_call (write_timeout); end Cleanup_Handler; end l6_ftf_; 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