



		    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
