PNOTICE_pcsf.alm 11/27/84 1141.2r w 11/27/84 1141.1 2448 dec 1 "version 1 structure dec 1 "no. of pnotices dec 3 "no. of STIs dec 56 "lgth of all pnotices + no. of pnotices acc "Copyright, (C) Honeywell Information Systems Inc., 1984" aci "C1PCSM0B0000" aci "C2PCSM0B0000" aci "C3PCSM0B0000" end  ibm_pc_io_.pl1 11/19/84 0940.6r w 11/19/84 0925.1 234261 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* format: style2 */ /* the user ring ibm_pc io module --- ibm_pc_io_ Uses the IBM PC-to-PC data transfer protocol as defined by IBM in their "Asynchronous Communication Support" manual, version 2.0. 1. Definitions CR$ Carriage Return (Hex 0D) (Oct 15) XON$ XON Character (Hex 11) (Oct 21) XOFF$ XOFF Character (Hex 13) (Oct 23) IBG$ Begin Transmission Code (Hex 1C) (Oct 34) ITM$ Terminate Transmission Code (Hex 17) (Oct 27) 2. Transmission Medium Level Protocol Asynchronous, 7 data bits. Files must be ASCII text files and have no lines longer than 250 characters. 3. Message Block Level Protocol The standard transmission portion of the block is a variable length character block, maximum 250 characters, followed by a carriage return. 4. Program Considerations 1. The program loops, reading the communications line and waiting for reception of a text line ending with the control characters IBG$CR$. 2. When such a line is received, the program sends a text line ending with IBG$CR$. (This line may contain an informative message as well, such as Starting file transmission) 3. The program transmits the file. Each line in the file should be sent as a line ending in a Carriage Return (CR$) 4. While transmission is taking place the program should monitor the input from the communications line and take the following actions: a. If an XOFF$CR$ is seen, stop transmission of lines. When an XON$CR$ is seen, resume transmission. b. If a line ending in ITM$CR$ is seen, stop all transmission. This line will contain as text the reason the receiving IBM Personal Computer has requested termination. c. When all lines in the file have been sent, the program should send a line ending in ITM$CR$. (This line can contain an appropriate message, such as "file transmission completed".) 5. Program Considerations 1. The program loops, sending out a message ending in IBG$CR$ every 15 to 20 seconds. This message may also contain text, such as Ready to receive file.) 2. During the loop in Step 1, the communications line is continually monitored for messages from the IBM Personal Computer. When a line ending in IBG$CR$ is received, the program moves on to step 3. 3. Each line received (after the one ending in IBG$CR$) is stored as a file record. As these lines end with Carriage Returns (CR$), the program might delete the CR$ before storing a line. Before storing a line, the program checks it to see if it ends in ITM$CR$. If it does, the program does not store that line, but closes the file and stops operation. 4. The program can stop transmission by the IBM Personal Computer by sending a line ending with an ITM$CR$. This line may also contain a message giving the reason for the termination. 5. If the program is receiving lines faster that they can be stored, it can suspend transmission by sending a line consisting of an XOFF$CR$ to the IBM Personal Computer. When it has caught up with the input, it can start up transmission by sending a line consisting of an XON$CR$ to the IBM Personal Computer. */ %page; ibm_pc_io_: proc; return; /* not an entry */ /* iox_ io module for ibm_pc protocol i/o written 6/84 by M.J. Mallmes */ /* Parameters */ dcl arg_actual_len fixed bin (21); dcl arg_buf_ptr ptr; /* ptr to user buffer (input) */ dcl arg_buf_len fixed bin (21); /* length of user buffer (input) */ dcl arg_iocbp ptr; /* ptr to iocb (input) */ dcl code fixed bin (35); /* Multics standard error code (output */ dcl com_err_switch bit (1) aligned; /* ON if should call com_err_ for errors (input) */ dcl mode fixed bin; dcl option_array (*) char (*) varying; /* Automatic */ dcl actual_iocbp ptr; /* copy of iocb.actual_iocb_ptr */ dcl arg_buf_pos fixed bin; /* index into passed argument buffer */ dcl attach_data_ptr ptr; /* ptr to iocb's attach_data */ dcl buf_ptr ptr; dcl buffer_empty bit (1); /* ON if a packet is to be received */ dcl buffer_full bit (1); /* ON if a packet is to be sent */ dcl carriage_return_found bit (1); dcl carriage_return_needed bit (1); dcl control_chars char (2); dcl ec fixed bin (35); dcl iocbp ptr; /* copy of arg_iocbp */ dcl mask bit (36) aligned; /* ips mask */ dcl system_free_area_ptr ptr; /* Based */ dcl 01 attach_data aligned based (attach_data_ptr), /* iocb attach_data */ 02 attach_descrip char (256) varying, 02 open_descrip char (32) varying, 02 target_iocbp ptr, /* ptr to target switch iocb */ 02 buf char (250), /* internal buffer */ 02 buf_pos fixed bin (21), /* index into buf */ 02 error_code fixed bin (35), /* 0 if normal close operation */ 02 xon_sw bit (1) unal, 02 eof_sw bit (1) unal; dcl 01 open_descrip based aligned, /* open description for iocb */ 02 length fixed bin (17), 02 string char (0 refer (open_descrip.length)); dcl system_free_area area based (system_free_area_ptr); /* Constants */ dcl One_Second fixed bin (71) static options (constant) init (1000000); dcl Ten_Seconds fixed bin (71) static options (constant) init (10000000); /* 110 seconds */ dcl Terminate_Transmission char (2) static options (constant) init (" "); dcl Buf_Size fixed bin (21) static options (constant) init (250); dcl Begin_Transmission char (2) static options (constant) init (" "); dcl Dim_name char (10) static options (constant) init ("ibm_pc_io_"); dcl XON char (2) static options (constant) init (" "); dcl XOFF char (2) static options (constant) init (" "); dcl CR char (1) static options (constant) init (" "); /* Builtin */ dcl (addcharno, addr, hbound, index, lbound, null, rtrim, substr) builtin; /* Conditions */ dcl (any_other, cleanup) condition; /* External Static */ dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$bad_mode fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$long_record fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$no_iocb fixed bin (35) ext static; dcl error_table_$not_attached fixed bin (35) ext static; dcl error_table_$not_detached fixed bin (35) ext static; dcl error_table_$not_open fixed bin (35) ext static; dcl error_table_$timeout fixed bin (35) ext static; dcl error_table_$unable_to_do_io fixed bin (35) ext static; /* Procedures */ dcl com_err_ entry () options (variable); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl iox_$err_no_operation entry () options (variable); dcl iox_$err_not_attached entry () options (variable); dcl iox_$err_not_open entry () options (variable); dcl iox_$err_not_closed entry () options (variable); dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$propagate entry (ptr); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl timed_io_$get_chars entry (ptr, fixed bin (71), ptr, fixed bin (21), fixed bin (21), fixed bin (35)); %page; /* Include Files */ %include iocb; %page; %include iox_modes; %page; /* This entry attaches the ibm_pc_io_ i/o module after verifying that the target switch is open for stream_input_output */ ibm_pc_io_attach: entry (arg_iocbp, option_array, com_err_switch, code); ec = 0; mask = ""b; iocbp = arg_iocbp; if hbound (option_array, 1) < 1 then call error (0, com_err_switch, error_table_$noarg, "Usage: ibm_pc_io_ switch_name {-control_arguments}"); attach_data_ptr = null (); on cleanup call clean_up_attach; if iocbp -> iocb.attach_descrip_ptr ^= null () then call error (0, com_err_switch, error_table_$not_detached, ""); system_free_area_ptr = get_system_free_area_ (); allocate attach_data in (system_free_area) set (attach_data_ptr); /* see if the target switch is attached and open for stream_input_output */ call iox_$look_iocb (rtrim (option_array (1)), target_iocbp, ec); if ec = error_table_$no_iocb then call error (1, com_err_switch, ec, rtrim (option_array (1))); if target_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr = null then call error (1, com_err_switch, error_table_$not_attached, rtrim (option_array (1))); if target_iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null then call error (1, com_err_switch, error_table_$not_open, rtrim (option_array (1))); if target_iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr -> open_descrip.string ^= iox_modes (Stream_input_output) then call error (1, com_err_switch, error_table_$bad_mode, rtrim (option_array (1))); attach_data.attach_descrip = Dim_name || " " || rtrim (option_array (1)); attach_data.open_descrip = ""; attach_data.eof_sw = "0"b; attach_data.buf_pos = 0; attach_data.error_code = 0; call hcs_$set_ips_mask (""b, mask); iocbp -> iocb.attach_data_ptr = attach_data_ptr; iocbp -> iocb.attach_descrip_ptr = addr (attach_data.attach_descrip); iocbp -> iocb.detach_iocb = ibm_pc_io_detach; iocbp -> iocb.open_descrip_ptr = null (); iocbp -> iocb.open = ibm_pc_io_open; iocbp -> iocb.modes = iox_$err_no_operation; iocbp -> iocb.control = iox_$err_no_operation; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, ""b); EXIT: return; %page; /* Error calls com_err_ if the loud switch is set and goes to the attach return */ error: proc (cleanup_level, call_com_err, ec, msg); dcl cleanup_level fixed bin; dcl call_com_err bit (1) aligned; dcl ec fixed bin (35); /* Multics standard error code */ dcl msg char (*); /* Additional error information */ goto Err (cleanup_level); Err (1): free attach_data; Err (0): if call_com_err then call com_err_ (ec, Dim_name, "^a", msg); code = ec; goto EXIT; end error; %page; /* This entry detaches the ibm_pc_io_ i/o module and frees the associated information */ ibm_pc_io_detach: entry (arg_iocbp, code); call set_up; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); actual_iocbp -> iocb.attach_descrip_ptr = null (); actual_iocbp -> iocb.attach_data_ptr = null (); actual_iocbp -> iocb.open = iox_$err_not_attached; actual_iocbp -> iocb.detach_iocb = iox_$err_not_attached; call iox_$propagate (actual_iocbp); call hcs_$reset_ips_mask (mask, "0"b); revert any_other; free attach_data; return; %page; /* This entry sets the open description and the legal operation entries in the iocb. Operation permitted: all the time: close input: get_chars, get_line output: put_chars Before returning it performs a handshake with the remote ibm_pc. */ ibm_pc_io_open: entry (arg_iocbp, mode, com_err_switch, code); on cleanup call terminate_io; call set_up; if mode ^= Stream_input & mode ^= Stream_output then do; code = error_table_$bad_mode; return; end; if mode = Stream_output then do; /* Perform handshake - sender */ call get_control_chars (control_chars, Ten_Seconds, ec); if control_chars = Terminate_Transmission then ec = error_table_$unable_to_do_io; do while ((ec = 0 | ec = error_table_$timeout) & control_chars ^= Begin_Transmission); call get_control_chars (control_chars, Ten_Seconds, ec); if control_chars = Terminate_Transmission then ec = error_table_$unable_to_do_io; end; if ec ^= 0 then do; code = error_table_$unable_to_do_io; return; end; /* The receiver sent IBG$CR$ so complete the handshake */ call send_control_chars (Begin_Transmission); attach_data.xon_sw = "1"b; end; if mode = Stream_input then do; /* Perform handshake - receiver */ call send_control_chars (Begin_Transmission); call get_control_chars (control_chars, Ten_Seconds, ec); if control_chars = Terminate_Transmission then ec = error_table_$unable_to_do_io; do while ((ec = 0 | ec = error_table_$timeout) & control_chars ^= Begin_Transmission); call send_control_chars (Begin_Transmission); call get_control_chars (control_chars, Ten_Seconds, ec); if control_chars = Terminate_Transmission then ec = error_table_$unable_to_do_io; end; if ec ^= 0 then do; code = error_table_$unable_to_do_io; return; end; end; attach_data_ptr -> attach_data.open_descrip = iox_modes (mode); on any_other call handler; call hcs_$set_ips_mask (""b, mask); actual_iocbp -> iocb.open_descrip_ptr = addr (attach_data.open_descrip); actual_iocbp -> iocb.open = iox_$err_not_closed; actual_iocbp -> iocb.close = ibm_pc_io_close; actual_iocbp -> iocb.detach_iocb = iox_$err_not_closed; if mode = Stream_input then do; actual_iocbp -> iocb.get_line = ibm_pc_io_get_line; actual_iocbp -> iocb.get_chars = ibm_pc_io_get_chars; end; else if mode = Stream_output then actual_iocbp -> iocb.put_chars = ibm_pc_io_put_chars; call iox_$propagate (actual_iocbp); call hcs_$reset_ips_mask (mask, ""b); revert any_other; return; %page; /* This procedure closes the ibm_pc i/o switch. If the switch was open for stream_output it flushes the output buffer and sends the ITM$CR$ control characters to the remote ibm_pc. If the last packet cannot be transmitted, the i/o switch is closed and the error code error_table_$unable_to_do_io is returned. */ ibm_pc_io_close: entry (arg_iocbp, code); on cleanup call terminate_io; call set_up; if actual_iocbp -> iocb.open_descrip_ptr -> open_descrip.string = iox_modes (Stream_output) & attach_data.error_code = 0 then do; buf_ptr = addr (attach_data.buf); if attach_data.buf_pos ^= 0 & substr (attach_data.buf, buf_pos, 1) ^= CR then do; attach_data.buf_pos = attach_data.buf_pos + 1; substr (attach_data.buf, attach_data.buf_pos, 1) = CR; end; call send_data_packet (ec); if attach_data.error_code = 0 then call terminate_io; end; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); actual_iocbp -> iocb.open_descrip_ptr = null; actual_iocbp -> iocb.open = ibm_pc_io_open; actual_iocbp -> iocb.detach_iocb = ibm_pc_io_detach; call iox_$propagate (actual_iocbp); call hcs_$reset_ips_mask (mask, "0"b); revert any_other; code = ec; return; /* This entry is called to input characters received from the remote connection. Packets are read until the user request is satisfied. Data received, but not requested by the user, is stored in an internal buffer, and is available on subsequent reads. */ ibm_pc_io_get_chars: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_actual_len, code); carriage_return_needed = "0"b; goto get_data; /* This entry is called to input characters received from the remote connection. Packets are read until the user request is satisfied. i.e. a carriage_return is found or the user buffer is filled. Data received, but not requested by the user, is stored in an internal buffer, and is available on subsequent reads */ ibm_pc_io_get_line: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_actual_len, code); carriage_return_needed = "1"b; get_data: on cleanup call terminate_io; call set_up; if arg_buf_len = 0 then return; if arg_buf_len < 0 then do; code = error_table_$bad_arg; return; end; carriage_return_found = "0"b; arg_buf_pos = 0; do while ("1"b); ec = 0; call unload_internal_buffer (buffer_empty); if buffer_empty then do; if attach_data.eof_sw then do; ec = error_table_$end_of_info; return; end; call get_data_packet (ec); if ec ^= 0 then do; if ec = error_table_$end_of_info then attach_data.eof_sw = "1"b; else call terminate_io; attach_data.buf_pos = 0; goto done_receive; end; end; else goto done_receive; end; done_receive: if (ec = 0) & carriage_return_needed & ^carriage_return_found then ec = error_table_$long_record; arg_actual_len = arg_buf_pos; code = ec; return; %page; /* This internal procedure moves the data from the internal buffer to the user's buffer during a get_chars or get_line operation. */ unload_internal_buffer: proc (buffer_empty); dcl buffer_empty bit (1); /* ON if we need more data from the remote ibm_pc */ dcl n_chars fixed bin; dcl overlay char (arg_buf_len) based; /* user buffer */ dcl i fixed bin; buffer_empty = "0"b; if attach_data.buf_pos = 0 then do; buffer_empty = "1"b; return; end; if arg_buf_len - arg_buf_pos > attach_data.buf_pos then n_chars = attach_data.buf_pos; else n_chars = arg_buf_len - arg_buf_pos; if carriage_return_needed then do; i = index (substr (attach_data.buf, 1, n_chars), CR); if i ^= 0 then do; carriage_return_found = "1"b; n_chars = i; end; end; substr (arg_buf_ptr -> overlay, arg_buf_pos + 1, n_chars) = substr (attach_data.buf, 1, n_chars); substr (attach_data.buf, 1, attach_data.buf_pos - n_chars) = substr (attach_data.buf, n_chars + 1, attach_data.buf_pos - n_chars); attach_data.buf_pos = attach_data.buf_pos - n_chars; arg_buf_pos = arg_buf_pos + n_chars; if (^carriage_return_found) & (arg_buf_pos < arg_buf_len) then buffer_empty = "1"b; return; end unload_internal_buffer; /* This internal procedure gets the actual packet from the remote ibm_pc during a get_chars or get_line operation. Data is received via variable length packets ending in a carriage return character. */ get_data_packet: proc (ec); dcl chase_buf_ptr ptr; dcl ec fixed bin (35); dcl n_read fixed bin (21); dcl to_read fixed bin (21); ec = 0; attach_data.buf_pos = 0; to_read = Buf_Size; buf_ptr = addr (attach_data.buf); chase_buf_ptr = buf_ptr; do while (to_read > 0 & ec = 0); call iox_$get_chars (attach_data.target_iocbp, chase_buf_ptr, to_read, n_read, ec); if ec ^= 0 then return; attach_data.buf_pos = attach_data.buf_pos + n_read; if substr (attach_data.buf, attach_data.buf_pos, 1) = CR then to_read = 0; else to_read = Buf_Size - attach_data.buf_pos; chase_buf_ptr = addcharno (buf_ptr, attach_data.buf_pos); end; if index (attach_data.buf, Terminate_Transmission) ^= 0 then ec = error_table_$end_of_info; return; end get_data_packet; %page; /* This entry is called to output characters to the remote connection. Data passed by the user is transmitted via variable length packets. Where each packet ends in a carriage return. Packets are transmitted until the user request is satisfied. */ ibm_pc_io_put_chars: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, code); /*** entry to perform put_chars operation */ on cleanup call terminate_io; call set_up; if arg_buf_len = 0 then return; if arg_buf_len < 0 then do; code = error_table_$bad_arg; return; end; arg_buf_pos = 0; buf_ptr = addr (attach_data.buf); do while ("1"b); ec = 0; call load_internal_buffer (buffer_full); if buffer_full then do; call send_data_packet (ec); if ec ^= 0 then do; call terminate_io; goto done_transmitting; end; else attach_data.buf_pos = 0; end; else goto done_transmitting; end; done_transmitting: code = ec; return; /* This internal procedure controls the necessary buffer operations during a put_chars operation. If the user's buffer contains more than 250 characters or the user's buffer contains a carriage return character then buffer_full = true. Otherwise, if a full packet cannot be sent (data does not end in a carriage return), data is stored in an internal buffer until (1) subsequent writes fill the buffer, or (2) the ibm_pc switch is closed, or (3) a subsequent write operation passes data containing a carriage return. */ load_internal_buffer: proc (buffer_full); dcl buffer_full bit (1); dcl CR_found bit (1); dcl n_chars fixed bin; dcl overlay char (arg_buf_len) based; dcl temp_buf_len fixed bin (21); buffer_full = "0"b; CR_found = "0"b; if arg_buf_pos = arg_buf_len then return; temp_buf_len = index (substr (arg_buf_ptr -> overlay, arg_buf_pos + 1, arg_buf_len - arg_buf_pos), CR); if temp_buf_len = 0 then temp_buf_len = arg_buf_len; else do; temp_buf_len = arg_buf_pos + temp_buf_len; CR_found = "1"b; end; if temp_buf_len - arg_buf_pos > Buf_Size - attach_data.buf_pos then n_chars = Buf_Size - attach_data.buf_pos; else n_chars = temp_buf_len - arg_buf_pos; substr (attach_data.buf, attach_data.buf_pos + 1, n_chars) = substr (arg_buf_ptr -> overlay, arg_buf_pos + 1, n_chars); arg_buf_pos = arg_buf_pos + n_chars; attach_data.buf_pos = attach_data.buf_pos + n_chars; if CR_found then buffer_full = "1"b; else if attach_data.buf_pos = Buf_Size then do; /* force a 250-character line */ arg_buf_pos = arg_buf_pos - 1; substr (attach_data.buf, Buf_Size, 1) = CR; buffer_full = "1"b; end; return; end load_internal_buffer; %page; /* This internal procedure sends a data packet during a put_chars operation. */ send_data_packet: proc (ec); dcl ec fixed bin (35); ec = 0; call get_control_chars (control_chars, One_Second, ec); if ec ^= 0 & ec ^= error_table_$timeout then goto send_data_error; if control_chars = XOFF then attach_data.xon_sw = "0"b; do while (^attach_data.xon_sw & control_chars ^= Terminate_Transmission); if control_chars = XON then attach_data.xon_sw = "1"b; if ^attach_data.xon_sw then call get_control_chars (control_chars, One_Second, ec); if ec ^= 0 & ec ^= error_table_$timeout then goto send_data_error; end; if control_chars = Terminate_Transmission then do; ec = error_table_$unable_to_do_io; attach_data.error_code = 1; return; end; call iox_$put_chars (attach_data.target_iocbp, buf_ptr, attach_data.buf_pos, ec); if ec ^= 0 then goto send_data_error; attach_data.buf_pos = 0; ec = 0; return; send_data_error: call terminate_io; return; end send_data_packet; /* This internal procedure sends a control character */ send_control_chars: proc (control_chars); dcl control_chars char (2); dcl control_char_ptr ptr; control_char_ptr = addr (control_chars); call iox_$put_chars (attach_data_ptr -> attach_data.target_iocbp, control_char_ptr, 2, (0)); return; end send_control_chars; /* Get a packet control character */ get_control_chars: proc (control_chars, interval, ec); dcl control_buf char (1); dcl control_buf_ptr ptr; dcl control_chars char (2); dcl ec fixed bin (35); dcl interval fixed bin (71); dcl n_read fixed bin (21); ec = 0; control_chars = " "; control_buf_ptr = addr (control_buf); control_buf = " "; do while (ec = 0); call timed_io_$get_chars (attach_data.target_iocbp, interval, control_buf_ptr, 1, n_read, ec); if ec ^= 0 then return; if control_buf ^= CR then substr (control_chars, 1, 1) = control_buf; else do; substr (control_chars, 2, 1) = control_buf; return; end; end; return; end get_control_chars; set_up: proc; /* fill in */ ec = 0; mask = ""b; actual_iocbp = arg_iocbp -> iocb.actual_iocb_ptr; attach_data_ptr = actual_iocbp -> iocb.attach_data_ptr; return; end set_up; /* Cleans up the attach data and allocated storage if the attach operation is aborted */ clean_up_attach: proc; if mask ^= ""b then call handler; /* Fatal error */ if attach_data_ptr = null () then return; free attach_data_ptr -> attach_data; return; end clean_up_attach; terminate_io: proc; attach_data.error_code = 1; call send_control_chars (Terminate_Transmission); return; end; %page; /* Internal procedure to handle faults while IPS interrupts are masked. For a fault while masked, the process is terminated (with the reason "unable to do critical I/O") because the I/O control blocks are in an inconsistent state */ handler: procedure options (non_quick); /* visible in ifd */ dcl error_table_$unable_to_do_io fixed (35) ext; if mask ^= ""b then call terminate_this_process (error_table_$unable_to_do_io); else return; end handler; terminate_this_process: proc (cd); dcl cd fixed bin (35); dcl terminate_process_ entry (char (*), ptr); dcl 01 ti aligned automatic, 02 version fixed, 02 code fixed (35); ti.version = 0; ti.code = code; call terminate_process_ ("fatal_error", addr (ti)); end terminate_this_process; end;  micro_transfer.pl1 10/17/88 1109.7r w 10/17/88 1034.1 244836 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* ************************************************************************** * * * Name: micro_transfer, mt * * * * This program acts as an interface between the Multics file system * * and I/O modules (protocols), when transferring files between Multics * * and a microcomputer. * * * * Status: * * * * 0) 24 August 1984: Initial coding, M. Mallmes. * * * * 1) 31 January 1985: Modified, M.Mallmes * * Changed the iocb-pointer passed to iox_$modes and * * iox_$control to use the user-supplied field and to * * default to the user_i/o switch iocb-pointer. * * Previous version always used the user_i/o switch * * iocb-pointer even when the user supplied a different * * switch. In summary, iox_$user_io has been replaced * * with mt_options.ts_iocbp. * * * * mt_options.new_modes now contains 'force'. * * deletes file if modes can't be set. * * * * * ************************************************************************* */ micro_transfer: mt: procedure () options (variable); /* Automatic */ dcl absolute_path char (168); dcl active_protocol fixed bin; dcl argument_count fixed bin; dcl arg_idx fixed bin; dcl argument_lth fixed bin (21); dcl argument_ptr ptr; dcl bit_count fixed bin (24); dcl buff char (256) aligned; dcl buf_ptr ptr; dcl call_com_err bit (1); dcl chars_written fixed bin (35); dcl code fixed bin (35); dcl default_modes bit (1); dcl dl_file bit (1); dcl message char (200); dcl modes_set bit (1) init ("0"b); dcl 01 mt_options unal, 02 ts_iocbp ptr aligned, 02 atd char (512), 02 eof_char char (256) var, 02 eol_str char (256) var, 02 io_switch char (32) var, 02 new_modes char (512), 02 path char (200), 02 protocol char (32), 02 sending bit (1), 02 receiving bit (1); dcl my_cl_intermediary entry variable; dcl n_read fixed bin (21); dcl new_delay_ptr ptr; dcl 01 new_delay_struc like delay_struc; dcl old_delay_ptr ptr; dcl 01 old_delay_struc like delay_struc; dcl old_modes char (256); dcl protocol_iocb_ptr ptr; dcl protocol_mode fixed bin; dcl protocol_swn char (32); dcl reset_cl_intermediary bit (1); dcl saved_cl_intermediary entry variable; dcl seg_iocb_ptr ptr; dcl seg_mode fixed bin; dcl seg_ptr ptr; dcl seg_swn char (32); dcl source_dir character (168); dcl source_ename character (32); dcl start_of_eol char (32) var; dcl 01 ti like terminal_info; dcl ti_ptr ptr; dcl transmission_time fixed bin (35); dcl whoami char (32); /* Based */ dcl argument character (argument_lth) based (argument_ptr); /* Constants */ dcl Buf_Size fixed bin (21) internal static options (constant) init (256); dcl Del_Switches bit (6) internal static options (constant) init ("100100"b) aligned; dcl IBM_PC fixed bin internal static options (constant) init (1); dcl MT_VERSION char (3) internal static options (constant) init ("1.0"); dcl NL char (1) internal static options (constant) init (" "); dcl OTHER fixed bin internal static options (constant) init (2); dcl XMODEM fixed bin internal static options (constant) init (0); /* Builtin */ dcl (abs, addr, after, before, ceil, index, length, mod, reverse, rtrim, null, substr, trunc) builtin; /* Conditions */ dcl cleanup condition; /* External */ dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$empty_file fixed bin (35) ext static; dcl error_table_$long_record fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$regexp_too_long fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$short_record fixed bin (35) ext static; /* Procedures */ dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry returns (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$cl entry (1 aligned, 2 bit (1) unal, 2 bit (35) unal); dcl cu_$generate_call entry (entry, ptr); dcl cu_$get_cl_intermediary entry (entry); dcl cu_$set_cl_intermediary entry (entry); dcl delete_$path entry (char (*), char (*), bit (6) aligned, char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ioa_ entry () options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed (35)); dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl nd_handler_ entry (char (*), char (*), char (*), fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* Include */ %page; %include access_mode_values; %page; %include iox_modes; %page; %include terminal_info; %page; %include terminate_file; %page; %include tty_convert; %page; /* micro_transfer: mt: procedure () options (variable); */ old_delay_ptr = null (); new_delay_ptr = null (); protocol_iocb_ptr = null (); seg_iocb_ptr = null (); seg_ptr = null (); old_modes = ""; whoami = "micro_transfer"; reset_cl_intermediary = "0"b; dl_file = "0"b; ti_ptr = addr (ti); ti.version = terminal_info_version; old_delay_struc.version = DELAY_VERSION; new_delay_struc.version = DELAY_VERSION; on cleanup call clean_up (0); /* Initialize control arguments, setting defaults where applicable */ mt_options.receiving = "0"b; mt_options.sending = "0"b; mt_options.eof_char = ""; mt_options.eol_str = ""; mt_options.protocol = " "; mt_options.io_switch = " "; mt_options.atd = "xmodem_io_ user_i/o"; mt_options.new_modes = " "; default_modes = "1"b; call cu_$arg_count (argument_count, code); if code ^= 0 then do; call com_err_ (code, whoami); return; end; if argument_count = 0 then do; USAGE: call com_err_ (error_table_$noarg, whoami, "^/Usage: ^a path {-control_args}", whoami); return; end; call cu_$arg_ptr (1, argument_ptr, argument_lth, code); /* get path */ if code ^= 0 then do; call com_err_ (error_table_$noarg, whoami, "^/Usage: ^a path {-control_args}", whoami); return; end; if index (argument, "-") ^= 1 then path = argument; else do; call com_err_ (error_table_$noarg, whoami, "^/Usage: ^a path {-control_args}", whoami); return; end; /* Scan for control arguments */ arg_idx = 2; do while (arg_idx <= argument_count); call cu_$arg_ptr (arg_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call com_err_ (code, argument, "Fetching argument #^d.", arg_idx); return; end; else if argument = "-send" then do; mt_options.sending = "1"b; mt_options.receiving = "0"b; end; else if argument = "-receive" then do; mt_options.receiving = "1"b; mt_options.sending = "0"b; end; else if argument = "-modes" then do; arg_idx = arg_idx + 1; call get_sub_arg; mt_options.new_modes = argument; default_modes = "0"b; end; else if argument = "-attach_description" | argument = "-atd" then do; arg_idx = arg_idx + 1; call get_sub_arg; mt_options.atd = argument; end; else if argument = "-eof" then do; arg_idx = arg_idx + 1; call get_sub_arg; mt_options.eof_char = argument; end; else if argument = "-eol" then do; arg_idx = arg_idx + 1; call get_sub_arg; mt_options.eol_str = argument; end; else do; BADOPT: call com_err_ (error_table_$badopt, whoami, "^a", argument); return; end; arg_idx = arg_idx + 1; end; /* Check arguments */ if ^mt_options.sending & ^mt_options.receiving then do; /* User didn't specify direction */ call com_err_ (error_table_$noarg, whoami, "^a ^a", "-send", "-receive"); return; end; if length (mt_options.eol_str) > 32 then do; call com_err_ (error_table_$regexp_too_long, whoami, "^a", mt_options.eol_str); return; end; if length (mt_options.eof_char) > 1 then do; call com_err_ (error_table_$regexp_too_long, whoami, "^a", mt_options.eof_char); return; end; call set_implicit_args; call expand_pathname_ (path, source_dir, source_ename, code); if code ^= 0 then do; call com_err_ (code, whoami, "^a", path); return; end; absolute_path = pathname_ (rtrim (source_dir), rtrim (source_ename)); if mt_options.receiving then do; /* Check file on Multics side */ call check_target_file (call_com_err, code); if code ^= 0 then do; if code = error_table_$action_not_performed then call clean_up (0); else if call_com_err then call com_err_ (code, whoami, "^a", rtrim (absolute_path)); return; end; seg_mode = Stream_output; protocol_mode = Stream_input; end; else do; /* Check file on Multics side */ call check_source_file (code, bit_count); if code ^= 0 then do; call com_err_ (code, whoami, "^a", rtrim (absolute_path)); return; end; seg_mode = Stream_input; protocol_mode = Stream_output; end; seg_swn = unique_chars_ (""b) || "." || rtrim (source_ename); protocol_swn = unique_chars_ (""b) || "." || rtrim (mt_options.protocol); /* Attach vfile_ */ call iox_$attach_name (seg_swn, seg_iocb_ptr, "vfile_ " || rtrim (absolute_path), null, code); if code ^= 0 then do; call clean_up (0); call com_err_ (code, whoami, "^a", rtrim (absolute_path)); return; end; call iox_$open (seg_iocb_ptr, seg_mode, "0"b, code); if code ^= 0 then do; call clean_up (0); call com_err_ (code, whoami, "^a", rtrim (absolute_path)); return; end; if mt_options.receiving then dl_file = "1"b; call iox_$look_iocb ((mt_options.io_switch), mt_options.ts_iocbp, code); if code ^= 0 then do; call com_err_ (code, whoami, "^a", mt_options.io_switch); return; end; /* Multics side okay, greet user */ call ioa_ ("Micro Transfer^xVersion^x^a", MT_VERSION); if mt_options.receiving then call ioa_ ("Receiving file ^a", rtrim (absolute_path)); else call display_send_info (bit_count); /* setup line modes */ /* Delays */ old_delay_ptr = addr (old_delay_struc); new_delay_ptr = addr (new_delay_struc); new_delay_struc.default = 0; new_delay_struc.delay.vert_nl = 0; new_delay_struc.delay.horz_nl = 0; new_delay_struc.delay.const_tab = 0; new_delay_struc.delay.var_tab = 0; new_delay_struc.delay.backspace = 0; new_delay_struc.delay.vt_ff = 0; call iox_$control (mt_options.ts_iocbp, "get_delay", old_delay_ptr, code); if code ^= 0 then do; call com_err_ (code, whoami); call clean_up (0); return; end; call iox_$control (mt_options.ts_iocbp, "set_delay", new_delay_ptr, code); if code ^= 0 then do; call com_err_ (code, whoami); call clean_up (0); return; end; /* Modes and cl_intermediary */ call cu_$get_cl_intermediary (saved_cl_intermediary); my_cl_intermediary = do_cl_intermediary; call cu_$set_cl_intermediary (my_cl_intermediary); reset_cl_intermediary = "1"b; call iox_$modes (mt_options.ts_iocbp, mt_options.new_modes, old_modes, code); if code ^= 0 then do; call com_err_ (code, whoami, "^a", mt_options.new_modes); call clean_up (0); return; end; modes_set = "1"b; /* Attach the I/O module */ call iox_$attach_name (protocol_swn, protocol_iocb_ptr, rtrim (mt_options.atd), null, code); if code ^= 0 then do; call clean_up (0); call com_err_ (code, whoami, "^a", mt_options.protocol); return; end; call iox_$open (protocol_iocb_ptr, protocol_mode, "0"b, code); if code ^= 0 then do; call clean_up (0); call com_err_ (code, whoami, "^a", mt_options.protocol); return; end; /* Do i/o */ dl_file = "0"b; buf_ptr = addr (buff); if protocol_mode = Stream_output then call send_data (code, message); else call get_data (code, message); if code ^= 0 then do; call clean_up (0); call com_err_ (code, whoami, "^a", rtrim (message)); return; end; call clean_up (code); /* Care about the close here */ if code ^= 0 then do; call com_err_ (code, whoami, "^a", mt_options.protocol); return; end; if mt_options.eof_char ^= "" & seg_mode = Stream_output then call strip_remote_eof (code); if code ^= 0 then call com_err_ (code, whoami, "^/a, ^a", "Unable to translate end-of-file character ", rtrim (absolute_path)); %page; /* This procedure returns the STR portion of a control argument */ get_sub_arg: proc; if arg_idx > argument_count then do; call com_err_ (error_table_$noarg, whoami); goto EXIT; end; call cu_$arg_ptr (arg_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call com_err_ (code, argument, "Fetching argument #^d.", arg_idx); goto EXIT; end; end get_sub_arg; %page; /* This procedure sets variables based on the command line input */ set_implicit_args: proc; mt_options.protocol = before (mt_options.atd, " "); mt_options.io_switch = before (after (mt_options.atd, " "), " "); if rtrim (mt_options.protocol) = "xmodem_io_" then do; active_protocol = XMODEM; if default_modes then mt_options.new_modes = "force,no_outp,8bit,breakall,^echoplex,rawi,^crecho,^lfecho,^tabecho,rawo"; end; else if rtrim (mt_options.protocol) = "ibm_pc_io_" then do; active_protocol = IBM_PC; if default_modes then mt_options.new_modes = "force,^8bit,breakall,^echoplex,rawi,^crecho,^lfecho,^tabecho,rawo"; end; else do; active_protocol = OTHER; if default_modes then mt_options.new_modes = "force,no_outp,8bit,breakall,^echoplex,rawi,^crecho,^lfecho,^tabecho,rawo"; end; return; end set_implicit_args; %page; /* This procedure checks out the integrity of the file to be received */ check_target_file: proc (call_com_err, ec); dcl bit_count fixed bin (24); dcl call_com_err bit (1); dcl ec fixed bin (35); call_com_err = "1"b; call initiate_file_ (source_dir, source_ename, N_ACCESS, seg_ptr, bit_count, ec); if ec = error_table_$noentry then ec = 0; if seg_ptr ^= null then do; call nd_handler_ (whoami, source_dir, source_ename, ec); call_com_err = "0"b; end; return; end check_target_file; %page; /* This procedure checks out the integrity of the file to be sent */ check_source_file: proc (ec, bit_count); dcl bit_count fixed bin (24); dcl ec fixed bin (35); call initiate_file_ (source_dir, source_ename, R_ACCESS, seg_ptr, bit_count, ec); if ec ^= 0 then return; if bit_count = 0 then do; ec = error_table_$empty_file; return; end; end check_source_file; %page; /* This procedure displays file information before sending a Multics file */ display_send_info: proc (bit_count); dcl bit_count fixed bin (24); dcl char_length fixed bin; dcl char_count fixed bin (35); dcl ec fixed bin (35); dcl packet_length fixed bin; dcl packet_overhead fixed bin; char_count = bit_count / 9; call ioa_ ("Sending file ^a:^x^d^xcharacters", rtrim (absolute_path), char_count); call iox_$control (mt_options.ts_iocbp, "terminal_info", ti_ptr, ec); if ec = 0 then do; goto init_info (active_protocol); init_info (0): /* XMODEM */ packet_overhead = 4; packet_length = 128; char_length = 8; goto end_init_info; init_info (1): /* IBM_PC */ packet_overhead = 1; packet_length = 1; /* Variable length packets */ char_length = 7; goto end_init_info; init_info (2): /* OTHER */ packet_overhead = 1; packet_length = 1; char_length = 8; end_init_info: bit_count = (char_count * char_length) + (abs (packet_length - mod (char_count, packet_length)) * char_length) + (ceil (char_count / packet_length) * packet_overhead); /* Real bit transmission count */ transmission_time = ceil (bit_count / ti.baud_rate); call ioa_ ("Approximate Send Time: ^d minutes, ^d seconds at ^d baud", trunc (transmission_time / 60), mod (transmission_time, 60), ti.baud_rate); end; return; end display_send_info; %page; /* mt's cl intermediary */ do_cl_intermediary: procedure; call mt_call_out (cu_$cl, cu_$arg_list_ptr ()); return; end do_cl_intermediary; /* This procedure handles modes setting in the event of a quit */ mt_call_out: procedure (Entry, Arg_list); dcl Entry variable entry parameter; dcl Arg_list ptr parameter; call iox_$modes (mt_options.ts_iocbp, old_modes, (""), 0); call cu_$set_cl_intermediary (saved_cl_intermediary); call cu_$generate_call (Entry, Arg_list); call iox_$modes (mt_options.ts_iocbp, mt_options.new_modes, old_modes, 0); call cu_$set_cl_intermediary (my_cl_intermediary); return; end mt_call_out; %page; /* This procedure reads from the protocol I/O module and writes the data to the Multics segment performing end-of-line and translations as necessary. */ get_data: proc (ec, message); dcl ec fixed bin (35); dcl eof bit (1); dcl message char (200); eof = "0"b; ec = 0; start_of_eol = ""; call iox_$get_chars (protocol_iocb_ptr, buf_ptr, Buf_Size - length (mt_options.eol_str), n_read, ec); do while (^eof); if ec = error_table_$end_of_info then do; eof = "1"b; end; else if ec ^= 0 then goto error_protocol_in; if mt_options.eol_str ^= "" then call translate_remote_eol (n_read, eof); call iox_$put_chars (seg_iocb_ptr, buf_ptr, n_read, ec); if ec ^= 0 then goto error_file_out; if ^eof then call iox_$get_chars (protocol_iocb_ptr, buf_ptr, Buf_Size - length (mt_options.eol_str), n_read, ec); end; ec = 0; return; error_protocol_in: message = mt_options.protocol; return; error_file_out: message = absolute_path; return; end get_data; %page; /* This procedure reads from the Multics segment and writes to the protocol I/O module performing end-of-line and end-of-file conversions as necessary */ send_data: proc (ec, message); dcl ec fixed bin (35); dcl eof_set bit (1); dcl message char (200); chars_written = 0; if mt_options.eol_str ^= "" then call iox_$get_line (seg_iocb_ptr, buf_ptr, Buf_Size - length (mt_options.eol_str), n_read, ec); else call iox_$get_chars (seg_iocb_ptr, buf_ptr, Buf_Size, n_read, ec); do while (ec ^= error_table_$end_of_info); if mt_options.eol_str ^= "" & n_read ^= 0 then call translate_mu_eol (n_read); chars_written = chars_written + n_read; /* need for xmodem */ if ec = error_table_$short_record then do; if mt_options.eof_char ^= "" then do; call add_remote_eof (n_read); eof_set = "1"b; end; end; else if ec = error_table_$long_record then ; else if ec ^= 0 then goto error_file_in; call iox_$put_chars (protocol_iocb_ptr, buf_ptr, n_read, ec); if ec ^= 0 then goto error_protocol_out; if mt_options.eol_str ^= "" then call iox_$get_line (seg_iocb_ptr, buf_ptr, Buf_Size - length (mt_options.eol_str), n_read, ec); else call iox_$get_chars (seg_iocb_ptr, buf_ptr, Buf_Size, n_read, ec); end; if ^eof_set & mt_options.eof_char ^= "" then do; call add_remote_eof (n_read); call iox_$put_chars (protocol_iocb_ptr, buf_ptr, n_read, ec); if ec ^= 0 then goto error_protocol_out; end; ec = 0; return; error_protocol_out: message = mt_options.protocol; return; error_file_in: message = absolute_path; return; end send_data; %page; /* This procedure adds the remote's eof character(s) */ add_remote_eof: proc (n_read); dcl i fixed bin; dcl n_pad fixed bin; dcl n_read fixed bin (21); goto case (active_protocol); case (0): /* XMODEM */ n_pad = Buf_Size / 2 - mod (chars_written, 128); do i = n_read + 1 to n_read + n_pad; substr (buff, i, 1) = mt_options.eof_char; end; n_read = n_read + n_pad; goto end_case; case (1): /* IBM_PC */ case (2): /* OTHER */ substr (buff, n_read + 1, 1) = mt_options.eof_char; n_read = n_read + 1; end_case: return; end add_remote_eof; %page; /* This procedure strips the remote eof character (s) */ strip_remote_eof: proc (ec); dcl char_count fixed bin (35); dcl done_searching bit (1); dcl ec fixed bin (35); dcl i fixed bin; dcl seg_ptr ptr; dcl overlay char (char_count) based (seg_ptr); call initiate_file_ (source_dir, source_ename, N_ACCESS, seg_ptr, bit_count, ec); if seg_ptr ^= null & ec = 0 then do; char_count = bit_count / 9; done_searching = "0"b; i = char_count; do while (i >= 1 & ^done_searching); if substr (seg_ptr -> overlay, i, 1) ^= mt_options.eof_char then i = i - 1; else do; do while (i >= 1 & ^done_searching); if substr (seg_ptr -> overlay, i, 1) = mt_options.eof_char then i = i - 1; else done_searching = "1"b; end; end; end; if i ^= char_count & done_searching then do; /* Have to reset the bit count */ bit_count = i * 9; call hcs_$set_bc_seg (seg_ptr, bit_count, ec); end; end; if seg_ptr ^= null then call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, 0); return; end strip_remote_eof; %page; /* This procedure translates a Multics NL to the remote eol character (s) */ translate_mu_eol: proc (n_read); dcl n_read fixed bin (21); if substr (buff, n_read, 1) = NL then do; substr (buff, n_read, length (mt_options.eol_str)) = mt_options.eol_str; n_read = n_read + length (mt_options.eol_str) - 1; end; end translate_mu_eol; /* This procedure translates the remote eol character (s) to a Multics NL. */ translate_remote_eol: proc (n_read, eof); dcl buf_pos fixed bin; dcl eof bit (1); dcl i fixed bin; dcl n_read fixed bin (21); dcl out_buf char (288) var; buf_pos = 0; out_buf = ""; /* See if we've got the last half of the end-of-line sequence */ if start_of_eol || substr (buff, 1, length (mt_options.eol_str) - length (start_of_eol)) = mt_options.eol_str then do; /* yes */ buf_pos = length (mt_options.eol_str) - length (start_of_eol); out_buf = NL; end; else out_buf = start_of_eol; /* No */ start_of_eol = ""; /* Now convert all full end-of-line sequences to a NL */ i = index (substr (buff, buf_pos + 1, n_read - buf_pos), mt_options.eol_str); do while (i ^= 0); out_buf = out_buf || substr (buff, buf_pos + 1, i - 1) || NL; buf_pos = buf_pos + i + length (mt_options.eol_str) - 1; i = index (substr (buff, buf_pos + 1, n_read - buf_pos), mt_options.eol_str); end; out_buf = out_buf || substr (buff, buf_pos + 1, n_read - buf_pos); n_read = length (out_buf); /* See if we still might have an end-of-line sequence beginning at the end of the buffer. i.e. split across two buffers */ if ^eof then do; i = index (reverse (out_buf), substr (mt_options.eol_str, 1, 1)); if i ^= 0 then do; buf_pos = length (out_buf) + 1 - i; if i < length (mt_options.eol_str) then do; if substr (out_buf, buf_pos, i) = substr (mt_options.eol_str, 1, i) then n_read = buf_pos - 1; end; end; /* There was a split, so save the first portion of the end-of-line sequence */ if n_read < length (out_buf) then start_of_eol = substr (out_buf, n_read + 1, i); end; substr (buff, 1, n_read) = substr (out_buf, 1, n_read); return; end translate_remote_eol; %page; /* This procedure restores the environment */ clean_up: proc (ec); dcl ec fixed bin (35); ec = 0; if protocol_iocb_ptr ^= null () then do; call iox_$close (protocol_iocb_ptr, ec); call iox_$detach_iocb (protocol_iocb_ptr, 0); end; if seg_iocb_ptr ^= null () then do; call iox_$close (seg_iocb_ptr, 0); call iox_$detach_iocb (seg_iocb_ptr, 0); end; if reset_cl_intermediary then call cu_$set_cl_intermediary (saved_cl_intermediary); if modes_set then call iox_$modes (mt_options.ts_iocbp, old_modes, "", 0); if old_delay_ptr ^= null then call iox_$control (mt_options.ts_iocbp, "set_delay", old_delay_ptr, 0); if seg_ptr ^= null then call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, 0); if dl_file then call delete_$path (source_dir, source_ename, Del_Switches, whoami, 0); return; end clean_up; EXIT: end;  xmodem_io_.pl1 11/19/84 0940.6r w 11/19/84 0925.2 309870 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* format: style2 */ /* the user ring xmodem io module --- xmodem_io_ Uses the xmodem protocol, defined by Ward Christensen, for data transfer. 1. Definitions 01(HEX) 01(OCT) 04(HEX) 04(OCT) 06(HEX) 06(OCT) 15(HEX) 25(OCT) 2. Transmission Medium Level Protocol Asynchronous, 8 data bits, no parity, one stop bit. There are no restrictions on the contents of the data being transmitted. Any kind of data may be sent: binary, ASCII, etc. No control characters are looked for in the 128-byte data messages. 3. Message Block Level Protocol The standard transmission portion of the block is a 132 character block without framing characters. Each block of the transfer looks like: <255-blk #><..128 data bytes..> where: = 01 (Hex). = binary number, starts at 01 increments by 1 and wraps 0FF (Hex) to 00 (Hex). <255-blk #> = The one's complement of the block number. = The sum of the data bytes only. 4. File Level Protocol 4a. Common to Both Sender and Receiver All errors are retried 10 times. 4b. Receive Program Considerations The receiver has a 10-second timeout. Once transmission begins, it sends a every time it times out. Before transmission begins, the receiver performs a handshake with the sender to determine the type of error detecting code to be used during transmission. If in checksum mode, the receiver's first timeout sends a to request checksum mode, and signals the transmitter to start. If in CRC mode, the receiver's first timeout sends a "C" to request CRC mode. It then waits for up to 10 seconds for an . This process continues until either (1) six "C"'s have been sent without receiving an , or (2) an is received within 10 seconds of sending a "C". If an is received within 10 seconds of sending a "C", it is assumed that the "C" was accepted by the sender and that it will send in CRC mode. If six "C"'s are sent without receiving an , the receiver switches to checksum mode and sends out a . Once into receiving a block, the receiver goes into a one-second timeout for each character and the checksum. If a valid block is received, the receiver will transmit an . For invalid blocks, a is transmitted. 4c. Sending Program Considerations The sender has a high-level 110-second timeout. If a timeout occurs, transmission is aborted. The sender starts transmission upon receipt of a or a "C". An initial causes the sender to transmit in checksum mode, while a "C" signals the sender to transmit in CRC mode. If the block was successfully received (receiver sends an ), the next block is sent. If the receiver responds with a , the sender retransmits the last block. When the sender has no more data, it sends an , and awaits an , resending the if it doesn't get one. Status: 0) 24 August 1984: Initial coding, M. Mallmes. */ %page; xmodem_io_: proc; return; /* not an entry */ /* iox_ io module for xmodem protocol i/o written 6/84 by M.J. Mallmes */ /* Parameters */ dcl arg_actual_len fixed bin (21); dcl arg_buf_ptr ptr; /* ptr to user buffer (input) */ dcl arg_buf_len fixed bin (21); /* length of user buffer (input) */ dcl arg_iocbp ptr; /* ptr to iocb (input) */ dcl code fixed bin (35); /* Multics standard error code (output */ dcl com_err_switch bit (1) aligned; /* ON if should call com_err_ for errors (input) */ dcl mode fixed bin; dcl option_array (*) char (*) varying; /* Automatic */ dcl actual_iocbp ptr; /* copy of iocb.actual_iocb_ptr */ dcl arg_buf_pos fixed bin; /* index into passed argument buffer */ dcl attach_data_ptr ptr; /* ptr to iocb's attach_data */ dcl block_rx char (1); dcl block_rx_1 char (1); dcl check_char (2) char (1); dcl buf_ptr ptr; dcl ec fixed bin (35); dcl edc fixed bin; dcl i fixed bin; dcl iocbp ptr; /* copy of arg_iocbp */ dcl mask bit (36) aligned; /* ips mask */ dcl newline_found bit (1); dcl newline_needed bit (1); dcl packet_type char (1); dcl retry_count fixed bin; dcl system_free_area_ptr ptr; dcl successful bit (1); dcl buffer_empty bit (1); /* ON of a packet is to be received */ dcl buffer_full bit (1); /* ON of a packet is to be sent */ /* Based */ dcl 01 attach_data aligned based (attach_data_ptr), /* iocb attach_data */ 02 attach_descrip char (256) varying, 02 open_descrip char (32) varying, 02 target_iocbp ptr, /* ptr to target switch iocb */ 02 buf char (128), /* internal buffer */ 02 buf_pos fixed bin (21), /* index into buf */ 02 my_rx_n uns fixed bin (9) unal, /* packet number when receiving */ 02 my_tx_n uns fixed bin (9) unal, /* packet number when sending */ 02 error_code fixed bin (35), /* 0 if normal close operation */ 02 crc_init bit (1) unal, 02 block_check_type fixed bin; /* Check type being used */ dcl 01 open_descrip based aligned, /* open description for iocb */ 02 length fixed bin (17), 02 string char (0 refer (open_descrip.length)); dcl system_free_area area based (system_free_area_ptr); /* Constants */ dcl Abort_Interval fixed bin (71) static options (constant) init (100000000); /* 110 seconds */ dcl ACK char (1) static options (constant) init (""); dcl Buf_Size fixed bin (21) static options (constant) init (128); dcl CAN char (1) static options (constant) init (""); dcl Check_Sum fixed bin static options (constant) init (1); dcl Cyclic_Redundancy_Code fixed bin static options (constant) init (2); dcl Dim_name char (10) static options (constant) init ("xmodem_io_"); dcl EOT char (1) static options (constant) init (""); dcl NAK char (1) static options (constant) init (""); dcl NL char (1) static options (constant) init (" "); dcl NUL char (1) static options (constant) init (""); dcl Retry_Threshold fixed bin static options (constant) init (10); dcl SOH char (1) static options (constant) init (""); dcl Timeout_Interval fixed bin (71) static options (constant) init (10000000); /* 10 seconds */ /* Builtin */ dcl (addcharno, addr, byte, bool, hbound, index, lbound, mod, null, rank, rtrim, substr, unspec) builtin; /* Conditions */ dcl (any_other, cleanup) condition; /* External Static */ dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$bad_mode fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$incompatible_attach fixed bin (35) ext static; dcl error_table_$long_record fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$no_iocb fixed bin (35) ext static; dcl error_table_$not_attached fixed bin (35) ext static; dcl error_table_$not_detached fixed bin (35) ext static; dcl error_table_$not_open fixed bin (35) ext static; dcl error_table_$timeout fixed bin (35) ext static; dcl error_table_$unable_to_do_io fixed bin (35) ext static; /* Procedures */ dcl com_err_ entry () options (variable); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl iox_$err_no_operation entry () options (variable); dcl iox_$err_not_attached entry () options (variable); dcl iox_$err_not_open entry () options (variable); dcl iox_$err_not_closed entry () options (variable); dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$propagate entry (ptr); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl timed_io_$get_chars entry (ptr, fixed bin (71), ptr, fixed bin (21), fixed bin (21), fixed bin (35)); %page; /* Include Files */ %include iocb; %page; %include iox_modes; %page; /* This entry attaches the xmodem_io_ i/o module after verifying that the target switch is open for stream_input_output */ xmodem_io_attach: entry (arg_iocbp, option_array, com_err_switch, code); ec = 0; mask = ""b; iocbp = arg_iocbp; if hbound (option_array, 1) < 1 then call error (0, com_err_switch, error_table_$noarg, "Usage: xmodem_io_ switch_name {-control_arguments}"); attach_data_ptr = null (); on cleanup call clean_up_attach; if iocbp -> iocb.attach_descrip_ptr ^= null () then call error (0, com_err_switch, error_table_$not_detached, ""); system_free_area_ptr = get_system_free_area_ (); allocate attach_data in (system_free_area) set (attach_data_ptr); /* see if the target switch is attached and open for stream_input_output */ call iox_$look_iocb (rtrim (option_array (1)), target_iocbp, ec); if ec = error_table_$no_iocb then call error (1, com_err_switch, ec, rtrim (option_array (1))); if target_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr = null then call error (1, com_err_switch, error_table_$not_attached, rtrim (option_array (1))); if target_iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null then call error (1, com_err_switch, error_table_$not_open, rtrim (option_array (1))); if target_iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr -> open_descrip.string ^= iox_modes (Stream_input_output) then call error (1, com_err_switch, error_table_$bad_mode, rtrim (option_array (1))); edc = Check_Sum; do i = lbound (option_array, 1) + 1 to hbound (option_array, 1); if option_array (i) = "-error_detection_code" | option_array (i) = "-edc" then do; i = i + 1; if i > hbound (option_array, 1) then call error (1, com_err_switch, error_table_$noarg, "-edc given without an error correction code"); if option_array (i) = "cyclic_redundancy_code" | option_array (i) = "crc" then edc = Cyclic_Redundancy_Code; else if option_array (i) = "check_sum" | option_array (i) = "cs" then edc = Check_Sum; else call error (1, com_err_switch, error_table_$badopt, rtrim (option_array (i))); end; else call error (1, com_err_switch, error_table_$badopt, rtrim (option_array (i))); end; attach_data.attach_descrip = Dim_name || " " || rtrim (option_array (1)); attach_data.open_descrip = ""; attach_data.block_check_type = edc; if edc = Cyclic_Redundancy_Code then attach_data.crc_init = "1"b; else attach_data.crc_init = "0"b; attach_data.my_rx_n = 1; attach_data.my_tx_n = 1; attach_data.buf_pos = 0; attach_data.error_code = 0; call hcs_$set_ips_mask (""b, mask); iocbp -> iocb.attach_data_ptr = attach_data_ptr; iocbp -> iocb.attach_descrip_ptr = addr (attach_data.attach_descrip); iocbp -> iocb.detach_iocb = xmodem_io_detach; iocbp -> iocb.open_descrip_ptr = null (); iocbp -> iocb.open = xmodem_io_open; iocbp -> iocb.modes = iox_$err_no_operation; iocbp -> iocb.control = iox_$err_no_operation; call iox_$propagate (iocbp); call hcs_$reset_ips_mask (mask, ""b); EXIT: return; %page; /* Error calls com_err_ if the loud switch is set and goes to the attach return */ error: proc (cleanup_level, call_com_err, ec, msg); dcl cleanup_level fixed bin; dcl call_com_err bit (1) aligned; dcl ec fixed bin (35); /* Multics standard error code */ dcl msg char (*); /* Additional error information */ goto Err (cleanup_level); Err (1): free attach_data; Err (0): if call_com_err then call com_err_ (ec, Dim_name, "^a", msg); code = ec; goto EXIT; end error; %page; /* This entry detaches the xmodem_io_ i/o module and frees the associated information */ xmodem_io_detach: entry (arg_iocbp, code); call set_up; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); actual_iocbp -> iocb.attach_descrip_ptr = null (); actual_iocbp -> iocb.attach_data_ptr = null (); actual_iocbp -> iocb.open = iox_$err_not_attached; actual_iocbp -> iocb.detach_iocb = iox_$err_not_attached; call iox_$propagate (actual_iocbp); call hcs_$reset_ips_mask (mask, "0"b); revert any_other; free attach_data; return; %page; /* This entry sets the open description and the legal operation entries in the iocb. Operation permitted: all the time: close input: get_chars, get_line output: put_chars Before returning it performs a handshake with the remote xmodem, determining the type of error correction code to be used. */ xmodem_io_open: entry (arg_iocbp, mode, com_err_switch, code); on cleanup attach_data.error_code = 1; call set_up; if mode = Stream_input | mode = Stream_output then do; if mode = Stream_output & crc_init then do; code = error_table_$incompatible_attach; return; end; else attach_data_ptr -> attach_data.open_descrip = iox_modes (mode); end; else do; code = error_table_$bad_mode; return; end; if mode = Stream_output then do; /* Perform handshake - sender */ call get_char (packet_type, Abort_Interval, ec); retry_count = 2; do while (ec = 0 & packet_type ^= NAK & packet_type ^= "C" & retry_count <= Retry_Threshold); call get_char (packet_type, Abort_Interval, ec); retry_count = retry_count + 1; end; if retry_count > Retry_Threshold | ec ^= 0 then do; if ec = error_table_$timeout | retry_count > Retry_Threshold then code = error_table_$unable_to_do_io; else code = ec; return; end; if packet_type = "C" then attach_data.block_check_type = Cyclic_Redundancy_Code; else attach_data.block_check_type = Check_Sum; end; if mode = Stream_input then do; /* Perform handshake - receiver */ if attach_data.crc_init then do; call get_data_packet (ec); if ec ^= 0 then do; attach_data.buf_pos = 0; code = ec; return; end; attach_data.my_rx_n = mod (attach_data.my_rx_n + 1, 256); attach_data.crc_init = "0"b; end; end; on any_other call handler; call hcs_$set_ips_mask (""b, mask); actual_iocbp -> iocb.open_descrip_ptr = addr (attach_data.open_descrip); actual_iocbp -> iocb.open = iox_$err_not_closed; actual_iocbp -> iocb.close = xmodem_io_close; actual_iocbp -> iocb.detach_iocb = iox_$err_not_closed; if mode = Stream_input then do; actual_iocbp -> iocb.get_line = xmodem_io_get_line; actual_iocbp -> iocb.get_chars = xmodem_io_get_chars; end; else if mode = Stream_output then actual_iocbp -> iocb.put_chars = xmodem_io_put_chars; call iox_$propagate (actual_iocbp); call hcs_$reset_ips_mask (mask, ""b); revert any_other; return; %page; /* This procedure closes the xmodem i/o switch. If the switch was open for stream_output it flushes the output buffer and sends an EOT control character to the remote xmodem. If the last packet cannot be transmitted, the i/o switch is closed and the error code error_table_$unable_to_do_io is returned. */ xmodem_io_close: entry (arg_iocbp, code); on cleanup attach_data.error_code = 1; call set_up; if actual_iocbp -> iocb.open_descrip_ptr -> open_descrip.string = iox_modes (Stream_output) & attach_data.error_code = 0 then do; call flush_output (ec); if ec = 0 then do; /* send EOT */ call send_char (EOT); call get_char (packet_type, Timeout_Interval, ec); do retry_count = 2 to Retry_Threshold while (packet_type ^= ACK | ec = error_table_$timeout); call send_char (EOT); call get_char (packet_type, Timeout_Interval, ec); end; end; if ec = error_table_$timeout | retry_count > Retry_Threshold then ec = error_table_$unable_to_do_io; end; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); actual_iocbp -> iocb.open_descrip_ptr = null; actual_iocbp -> iocb.open = xmodem_io_open; actual_iocbp -> iocb.detach_iocb = xmodem_io_detach; call iox_$propagate (actual_iocbp); call hcs_$reset_ips_mask (mask, "0"b); revert any_other; code = ec; return; /* flush_output transmits any remaining data to the remote xmodem during a close operation. The last data packet sent is filled with the NUL ascii character, if and only if it is not a multiple of 128. */ flush_output: proc (ec); dcl ec fixed bin (35); dcl n_chars fixed bin; ec = 0; buf_ptr = addr (attach_data.buf); if attach_data.buf_pos = 0 then return; do n_chars = attach_data.buf_pos + 1 to Buf_Size; substr (attach_data.buf, n_chars, 1) = NUL; end; call send_data_packet (ec); return; end flush_output; %page; /* This entry is called to input characters received from the remote connection. Packets are read until the user request is satisfied. Data received, but not requested by the user, is stored in an internal buffer, and is available on subsequent reads. */ xmodem_io_get_chars: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_actual_len, code); newline_needed = "0"b; goto get_data; /* This entry is called to input characters received from the remote connection. Packets are read until the user request is satisfied. i.e. a newline is found or the user buffer is filled. Data received, but not requested by the user, is stored in an internal buffer, and is available on subsequent reads */ xmodem_io_get_line: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_actual_len, code); newline_needed = "1"b; get_data: on cleanup attach_data.error_code = 1; call set_up; if arg_buf_len = 0 then return; if arg_buf_len < 0 then do; code = error_table_$bad_arg; return; end; newline_found = "0"b; arg_buf_pos = 0; do while ("1"b); ec = 0; call unload_internal_buffer (buffer_empty); if buffer_empty then do; call get_data_packet (ec); if ec ^= 0 then do; attach_data.buf_pos = 0; attach_data.error_code = ec; goto done_receive; end; else attach_data.my_rx_n = mod (attach_data.my_rx_n + 1, 256); end; else goto done_receive; end; done_receive: if (ec = 0) & newline_needed & ^newline_found then ec = error_table_$long_record; arg_actual_len = arg_buf_pos; code = ec; return; %page; /* This internal procedure moves the data from the internal buffer to the user's buffer during a get_chars or get_line operation. */ unload_internal_buffer: proc (buffer_empty); dcl buffer_empty bit (1); /* ON if we need more data from the remote xmodem */ dcl n_chars fixed bin; dcl overlay char (arg_buf_len) based; /* user buffer */ dcl i fixed bin; buffer_empty = "0"b; if attach_data.buf_pos = 0 then do; buffer_empty = "1"b; return; end; if arg_buf_len - arg_buf_pos > attach_data.buf_pos then n_chars = attach_data.buf_pos; else n_chars = arg_buf_len - arg_buf_pos; if newline_needed then do; i = index (substr (attach_data.buf, 1, n_chars), NL); if i ^= 0 then do; newline_found = "1"b; n_chars = i; end; end; substr (arg_buf_ptr -> overlay, arg_buf_pos + 1, n_chars) = substr (attach_data.buf, 1, n_chars); substr (attach_data.buf, 1, attach_data.buf_pos - n_chars) = substr (attach_data.buf, n_chars + 1, attach_data.buf_pos - n_chars); attach_data.buf_pos = attach_data.buf_pos - n_chars; arg_buf_pos = arg_buf_pos + n_chars; if (^newline_found) & (arg_buf_pos < arg_buf_len) then buffer_empty = "1"b; return; end unload_internal_buffer; /* This internal procedure gets the actual packet from the remote xmodem during a get_chars or get_line operation. Data is received via packets of the following form: <^BLOCK #><128 data characters> Acknowledge its receipt by sending either an ACK or NAK */ get_data_packet: proc (ec); dcl bad_char bit (1); dcl chase_buf_ptr ptr; dcl ec fixed bin (35); dcl n_read fixed bin (21); dcl soh_eot_char char (1); dcl to_read fixed bin (21); retry_count = 1; do while (retry_count <= Retry_Threshold); bad_char = "0"b; ec = 0; /* Get the SOH character */ call get_char (soh_eot_char, Timeout_Interval, ec); if ec ^= 0 then goto try_again; if soh_eot_char = EOT then do; ec = error_table_$end_of_info; call send_char (ACK); return; end; else if soh_eot_char ^= SOH then do; bad_char = "1"b; goto try_again; end; /* Get the block number */ call get_char (block_rx, Timeout_Interval, ec); if ec ^= 0 then goto try_again; if attach_data.my_rx_n ^= rank (block_rx) then do; /* Our last ACK may have been garbled */ if attach_data.my_rx_n ^= mod (rank (block_rx) + 1, 256) then bad_char = "1"b; goto try_again; end; /* Get the block number complement */ call get_char (block_rx_1, Timeout_Interval, ec); if ec ^= 0 then goto try_again; if (255 - attach_data.my_rx_n) ^= rank (block_rx_1) then do; /* Bad complement */ bad_char = "1"b; /* only complement bad so try again */ goto try_again; end; /* Get the data (128 characters) */ buf_ptr = addr (attach_data.buf); chase_buf_ptr = buf_ptr; attach_data.buf_pos = 0; to_read = Buf_Size; do while (to_read > 0 & ec = 0); call timed_io_$get_chars (attach_data.target_iocbp, Timeout_Interval, chase_buf_ptr, to_read, n_read, ec); if ec ^= 0 then goto try_again; else do; attach_data.buf_pos = n_read + attach_data.buf_pos; chase_buf_ptr = addcharno (buf_ptr, attach_data.buf_pos); to_read = Buf_Size - attach_data.buf_pos; end; end; /* Get the checksum character */ call get_char (check_char (1), Timeout_Interval, ec); if ec ^= 0 then goto try_again; /* Verify the data received */ if attach_data.block_check_type = Check_Sum then do; if rank (check_char (1)) ^= my_checksum () then bad_char = "1"b; end; else do; call get_char (check_char (2), Timeout_Interval, ec); if ec ^= 0 then goto try_again; if ^good_crc (check_char) then bad_char = "1"b; end; if ^bad_char then do; call flush_input; call send_char (ACK); return; end; try_again: call flush_input; if (ec ^= 0) | bad_char then do; if attach_data.crc_init /* First time, must agree on error code */ then do; if retry_count <= 6 then call send_char ("C"); else do; attach_data.crc_init = "0"b; attach_data.block_check_type = Check_Sum; call send_char (NAK); end; end; else call send_char (NAK); end; else call send_char (ACK); retry_count = retry_count + 1; end; if retry_count > Retry_Threshold then ec = error_table_$unable_to_do_io; return; end get_data_packet; /* flush_input throws out any data that was sent by the remote xmodem but is not required during a get_chars operation because: 1. It is known that the current packet is bad. 2. An ACK or NAK is to be sent in response to the packet received, or not received. */ flush_input: proc; dcl bad_char char (1); dcl bad_char_ptr ptr; dcl ec fixed bin (35); dcl interval fixed bin (71) init (1000000); /* one second */ dcl n_read fixed bin (21); ec = 0; bad_char_ptr = addr (bad_char); do while (ec = 0); call timed_io_$get_chars (attach_data.target_iocbp, interval, bad_char_ptr, 1, n_read, ec); end; return; end flush_input; %page; /* This entry is called to output characters to the remote connection. Data passed by the user is transmitted via packets of the following form: <^BLOCK #><128 data characters> Packets are transmitted until the user request is satisfied. If a full packet cannot be sent, data is stored in an internal buffer until (1) subsequent writes fill the buffer, or (2) the xmodem switch is closed */ xmodem_io_put_chars: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, code); /*** entry to perform put_chars operation */ on cleanup attach_data.error_code = 1; call set_up; if arg_buf_len = 0 then return; if arg_buf_len < 0 then do; code = error_table_$bad_arg; return; end; arg_buf_pos = 0; buf_ptr = addr (attach_data.buf); do while ("1"b); ec = 0; call load_internal_buffer (buffer_full); if buffer_full then do; call send_data_packet (ec); if ec ^= 0 then do; attach_data.error_code = ec; goto done_transmitting; end; else do; attach_data.my_tx_n = mod (attach_data.my_tx_n + 1, 256); attach_data.buf_pos = 0; end; end; else goto done_transmitting; end; done_transmitting: code = ec; return; /* This internal procedure controls the necessary buffer operations during a put_chars operation. If the user's buffer is a multiple of 128 characters then the data is sent directly from the user's buffer; otherwise the data is placed in an internal buffer before transmission. */ load_internal_buffer: proc (buffer_full); dcl buffer_full bit (1); dcl n_chars fixed bin; dcl overlay char (arg_buf_len) based; buffer_full = "0"b; if arg_buf_pos = arg_buf_len then return; if mod (arg_buf_len - arg_buf_pos, Buf_Size) = 0 & (attach_data.buf_pos = 0) then do; /* User's buffer is a multiple of 128 characters */ buf_ptr = addcharno (arg_buf_ptr, arg_buf_pos); arg_buf_pos = arg_buf_pos + Buf_Size; buffer_full = "1"b; return; end; if arg_buf_len - arg_buf_pos > Buf_Size - attach_data.buf_pos then n_chars = Buf_Size - attach_data.buf_pos; else n_chars = arg_buf_len - arg_buf_pos; substr (attach_data.buf, attach_data.buf_pos + 1, n_chars) = substr (arg_buf_ptr -> overlay, arg_buf_pos + 1, n_chars); arg_buf_pos = arg_buf_pos + n_chars; if attach_data.buf_pos + n_chars = Buf_Size then buffer_full = "1"b; else attach_data.buf_pos = attach_data.buf_pos + n_chars; return; end load_internal_buffer; %page; /* This internal procedure sends a data packet during a put_chars operation. The data packet is retransmitted until a timeout occurs, the packet is acknowledged, or the Retry_Threshold is reached */ send_data_packet: proc (ec); dcl ec fixed bin (35); ec = 0; successful = "0"b; retry_count = 1; do while (^successful & retry_count <= Retry_Threshold); /* Send packet */ call send_char (SOH); call send_char (byte (attach_data.my_tx_n)); call send_char (byte (255 - attach_data.my_tx_n)); call send_data; if attach_data.block_check_type = Check_Sum then call send_char (byte (my_checksum ())); else do; call my_crc (check_char); call send_char (check_char (1)); call send_char (check_char (2)); end; call get_char (packet_type, Abort_Interval, ec); if ec ^= 0 then do; if ec = error_table_$timeout then ec = error_table_$unable_to_do_io; return; end; if packet_type = CAN then do; ec = error_table_$unable_to_do_io; return; end; if packet_type = ACK then successful = "1"b; else retry_count = retry_count + 1; end; if retry_count > Retry_Threshold then do; ec = error_table_$unable_to_do_io; return; end; attach_data.buf_pos = 0; ec = 0; return; end send_data_packet; /* This internal procedure sends the data portion of the packet during a put_chars operation. */ send_data: proc; call iox_$put_chars (attach_data.target_iocbp, buf_ptr, Buf_Size, code); return; end send_data; /* This internal procedure sends a control character */ send_char: proc (control_char); dcl control_char char (1); dcl control_char_ptr ptr; control_char_ptr = addr (control_char); call iox_$put_chars (attach_data_ptr -> attach_data.target_iocbp, control_char_ptr, 1, (0)); return; end send_char; %page; /* Get the checksum character for the packet (8 bits). It is the sum of the data characters only */ my_checksum: /* checksum, 8-bit sum of data bytes only */ proc returns (fixed bin (9)); dcl chksum fixed bin (9); dcl i fixed bin; dcl overlay (128) char (1) based unal; chksum = 0; do i = 1 to Buf_Size; chksum = mod (chksum + rank (buf_ptr -> overlay (i)), 256); end; return (chksum); end my_checksum; /* This procedure performs the CRC-CCITT calculation resulting in a 16-bit error-detecting-code. 1. Let r be the degree of the generator polynomial, G(x), where G(x) = x**16 + x**12 + x**5 + 1. Append r zero bits to the low-order end of the message, so it now contains m+r bits. 2. Divide the bit string corresponding to G(x) into the bit string corresponding to m+r bits. (m+r bits is hereafter referred to as M(x). 3. Subtract the remainder (which is alway r or fewer bits) from the bit string M(x) using modulo 2 subtraction. The result is the checksummed message to be transmitted. */ my_crc: /* CRC-CCITT */ proc (crc_char); dcl crc_char (2) char (1); dcl dividend bit (1168) var; dcl i fixed bin; dcl 01 overlay (128) based unal, 02 pad bit (1), 02 mx_char bit (8); dcl remainder bit (16); dividend = ""b; do i = 1 to 128; dividend = dividend || buf_ptr -> overlay.mx_char (i); end; dividend = dividend || "0000"b4; remainder = mod2_div (dividend); unspec (crc_char (1)) = "0"b || substr (remainder, 1, 8); unspec (crc_char (2)) = "0"b || substr (remainder, 9, 8); return; end; /* Receiving - divide the message by the generator polynomial. If there is no remainder, the message is correct */ good_crc: proc (crc_char) returns (bit (1)); dcl crc_char (2) char (1); dcl crc_bits (2) bit (9) based (addr (crc_char)); dcl dividend bit (1168) var; dcl i fixed bin; dcl 01 overlay (128) based unal, 02 pad bit (1), 02 mx_char bit (8); dcl remainder bit (16); dividend = ""b; do i = 1 to 128; dividend = dividend || buf_ptr -> overlay.mx_char (i); end; dividend = dividend || substr (crc_bits (1), 2, 8) || substr (crc_bits (2), 2, 8); remainder = mod2_div (dividend); if remainder = "0"b then return ("1"b); else return ("0"b); end good_crc; mod2_div: proc (dividend) returns (bit (16)); dcl dividend bit (*) var; /*128 data words + 16-bit crc */ dcl GX bit (17) init ("10001000000100001"b); dcl i fixed bin; dcl length builtin; dcl remainder bit (16); dcl XOR bit (4) init ("0110"b); remainder = "0"b; i = index (dividend, "1"b); if i ^= 0 then dividend = substr (dividend, i, length (dividend) - i + 1); else dividend = "0"b; do while (length (dividend) > length (GX) - 1); dividend = bool (substr (dividend, 1, length (GX)), GX, XOR) || substr (dividend, length (GX) + 1, length (dividend) - length (GX)); i = index (dividend, "1"b); if i ^= 0 then dividend = substr (dividend, i, length (dividend) - i + 1); else dividend = "0"b; end; substr (remainder, length (remainder) - length (dividend) + 1, length (dividend)) = dividend; return (remainder); end mod2_div; /* Get a packet control character */ get_char: proc (packet_type, interval, ec); dcl packet_type char (1); dcl ec fixed bin (35); dcl interval fixed bin (71); dcl n_read fixed bin (21); dcl packet_type_ptr ptr; packet_type = ""; packet_type_ptr = addr (packet_type); call timed_io_$get_chars (attach_data.target_iocbp, interval, packet_type_ptr, 1, n_read, ec); return; end get_char; set_up: proc; /* fill in */ ec = 0; mask = ""b; actual_iocbp = arg_iocbp -> iocb.actual_iocb_ptr; attach_data_ptr = actual_iocbp -> iocb.attach_data_ptr; return; end set_up; /* Cleans up the attach data and allocated storage if the attach operation is aborted */ clean_up_attach: proc; if mask ^= ""b then call handler; /* Fatal error */ if attach_data_ptr = null () then return; free attach_data_ptr -> attach_data; return; end clean_up_attach; %page; /* Internal procedure to handle faults while IPS interrupts are masked. For a fault while masked, the process is terminated (with the reason "unable to do critical I/O") because the I/O control blocks are in an inconsistent state */ handler: procedure options (non_quick); /* visible in ifd */ dcl error_table_$unable_to_do_io fixed (35) ext; if mask ^= ""b then call terminate_this_process (error_table_$unable_to_do_io); else return; end handler; terminate_this_process: proc (cd); dcl cd fixed bin (35); dcl terminate_process_ entry (char (*), ptr); dcl 01 ti aligned automatic, 02 version fixed, 02 code fixed (35); ti.version = 0; ti.code = code; call terminate_process_ ("fatal_error", addr (ti)); end terminate_this_process; end; 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