dev_file_transfer_.pl1 09/23/77 1031.6rew 09/22/77 1724.6 119286 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ dev_file_transfer_: procedure (P_IB_ptr, argument); /* A Pogran Program, 09/16/74 This program implements the Server Side of the special Development Machine File Transfer software. Modified by Ken Pogran, 10/02/74 Modified by Ken Pogran to incorporate auditing suggestions 3/12/75 Modified by D. M. Wells to change ftp_data declarations 12/76 */ declare argument char (*), P_IB_ptr ptr; declare 1 ftp_data aligned like ftp_data_template defined (P_IB_ptr -> ftp_data_template); declare byte_size fixed bin (8), bytes_read fixed bin (24), bytes_written fixed bin (24) initial (0), code fixed bin (35), dirname char (168), ename char (32), error_message char (100) aligned initial (""), error_message_length fixed bin (24), later fixed bin (71), mode char (4), offset fixed bin (24), record_quota_overflow condition, segment_ptr pointer initial (null), segptr pointer, short_message char (8) aligned, state fixed bin (6), status_bits bit (72) aligned; declare 1 io_status aligned based (addr (status_bits)), 2 code fixed bin (35), 2 stuff bit (36); declare 1 wait_list aligned automatic, 2 count fixed binary (17) initial (1), 2 channel fixed binary (71) initial (P_IB_ptr -> ftp_data_template.event_channel); declare 1 event_message aligned, 2 channel fixed bin (71), 2 message fixed bin (71), 2 more_stuff (4) bit (36); declare segment (offset) bit (36) aligned based; %include ftp_server_data; declare clock_ entry returns (fixed bin (71)), convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned), cv_dec_ entry (char (*)) returns (fixed bin (35)), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), ftp_initialization_$cleanup entry (ptr, bit (1)), ftp_initialization_$socket_init entry (ptr, fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), ioa_ entry options (variable), ioa_$rsnnl entry options (variable), ioa_$ioa_stream_nnl entry options (variable), ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned), ios_$detach entry (char (*), char (*), char (*), bit (72) aligned), ios_$order entry (char (*), char (*), ptr, bit (72) aligned), ios_$write entry (char (*), ptr, fixed bin (24), fixed bin (24), fixed bin (24), bit (72) aligned), ipc_$block entry (ptr, ptr, fixed bin (35)), ncp_$initiate_connection entry (bit (36), fixed bin (16), fixed bin (32), fixed bin (6), fixed bin (35)), ncp_$close_connection entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$get_socket_state entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$read_data entry (bit (36), ptr, fixed bin (24), fixed bin (24), fixed bin (6), fixed bin (35)), ncp_$set_bytesize entry (bit (36), fixed bin (8), fixed bin (35)), timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)), timer_manager_$reset_alarm_wakeup entry (fixed bin (71)); declare (addr, null, substr, index, pointer, length) builtin; call hcs_$make_seg ("", "dev_file_transfer_temp", "", 1010b, segptr, code); if segptr = null then go to return_decoded_error; mode = substr (argument, 6, 4); if mode = "seg" then do; byte_size = 36; call expand_pathname_ (substr (argument, 24), dirname, ename, code); if code ^= 0 then go to return_decoded_error; call hcs_$make_seg (dirname, ename, "", 1010b, segment_ptr, code); if segment_ptr = null then go to return_decoded_error; end; else if mode = "prt" then do; byte_size = 9; call ios_$attach ("output_stream", "prtdim_", substr (argument, 11, 4), "", status_bits); if io_status.code ^= 0 then do; code = io_status.code; go to return_decoded_error; end; call ios_$order ("output_stream", "inside_page", null, status_bits); end; else if mode = "tape" then do; byte_size = 36; call ios_$attach ("output_stream", "tape_", substr (argument, 11, length (argument) - 10), "w", status_bits); if io_status.code = 0 then call ioa_ ("+"); else do; code = io_status.code; go to return_decoded_error; end; end; else do; call ioa_ ("-Bad mode specification: ^a", mode); return; end; call ftp_initialization_$socket_init (addr (ftp_data), code); if code ^= 0 then go to return_decoded_error; call ncp_$set_bytesize (ftp_data.read_index, byte_size, code); if code ^= 0 then go to return_decoded_error; call ncp_$initiate_connection (ftp_data.read_index, ftp_data.foreign_host, ftp_data.foreign_write_socket, state, code); if code ^= 0 then go to return_decoded_error; later = clock_() + 15000000; call timer_manager_$alarm_wakeup (later, "00"b, ftp_data.event_channel); check_state: call ncp_$get_socket_state (ftp_data.read_index, state, code); if code ^= 0 then go to return_decoded_error; if ^(state = 6 | state = 11) then if state = 5 then do; if clock_ () > later then do; error_message = "Data connection not accepted by Service System."; go to terminate_and_return; end; call ipc_$block (addr (wait_list), addr (event_message), code); if code ^= 0 then go to return_decoded_error; go to check_state; end; else if state = 1 then do; error_message = "Data connection refused by Service System."; go to terminate_and_return; end; else do; call ioa_$rsnnl ("Data connection in improper state ^d.", error_message, error_message_length, state); call ncp_$close_connection (ftp_data.read_index, state, code); go to terminate_and_return; end; call timer_manager_$reset_alarm_wakeup (ftp_data.event_channel); if mode = "seg" then do offset = 0 repeat (offset + bytes_read) while (state = 6 | state = 11); call ncp_$read_data (ftp_data.read_index, pointer (segptr, offset), 100000, bytes_read, state, code); if code = 0 then if bytes_read = 0 then if state = 6 then do; call ipc_$block (addr (wait_list), addr (event_message), code); if code ^= 0 then go to return_decoded_error; end; end; else do; do while (state = 6 | state = 11); call ncp_$read_data (ftp_data.read_index, segptr, 100000, bytes_read, state, code); if code = 0 then if bytes_read = 0 then if state = 6 then do; call ipc_$block (addr (wait_list), addr (event_message), code); if code ^= 0 then go to return_decoded_error; end; else; else do offset = 0 repeat (offset + bytes_written) while (offset < bytes_read); call ios_$write ("output_stream", segptr, offset, bytes_read - offset, bytes_written, status_bits); if io_status.code ^= 0 then do; code = io_status.code; go to return_decoded_error; end; end; end; if mode = "prt" then call ioa_$ioa_stream_nnl ("output_stream", "^2|"); call ios_$detach ("output_stream", "", "", status_bits); if io_status.code ^= 0 then do; code = io_status.code; go to return_decoded_error; end; end; if state = 1 then if mode = "seg" then do; on condition (record_quota_overflow) begin; call ioa_$rsnnl ("Record quota overflow in ^a; transfer of ^a is incomplete.", error_message, error_message_length, dirname, ename); go to terminate_and_return; end; segment_ptr -> segment = segptr -> segment; revert condition (record_quota_overflow); call hcs_$set_bc_seg (segment_ptr, cv_dec_ (substr (argument, 11, 12)), code); end; else; else call ioa_$rsnnl ("Data connection in improper state ^d at end of data transfer.", error_message, error_message_length, state); terminate_and_return: call ftp_initialization_$cleanup (addr (ftp_data), "0"b); if mode = "seg" then call hcs_$terminate_noname (segment_ptr, code); if error_message = "" then call ioa_ ("+"); else call ioa_ ("-^a", error_message); return; return_decoded_error: call convert_status_code_ (code, short_message, error_message); go to terminate_and_return; end dev_file_transfer_;  file_transfer_.pl1 10/03/77 1118.4rew 10/03/77 0930.1 366489 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ file_transfer_: file_transfer: procedure (P_IB_ptr); /* A Pogran Program 02/08/73 This module implements the actual file transfer functions of the Multics File Transfer Server. The retrieve, store, append, and abort entries are intended to be called by the ftp_command_processor_. However, the module is designed so that eventually there can be a file_transfer command which does not require that the user be logged in over the Network, nor that he be in the FTP server environment. This feature is not implemented at the present time. Modified 02/28/73 by K. T. Pogran. Added mail_transfer entry and modifications 04/12/73; K. T. Pogran. Modified 11-15-73 by Kobziar to drop append access. Modified 10/21/74 by K. T. Pogran to add File Access Protocol features, and reorganize. Modified 10/25/74 by K. T. Pogran Modified to add the list_transfer entry by Ken Pogran, 3/4/75 Modified 08/27/76 by D. M. Wells, to get rid of 455 reply codes. */ declare code fixed bin (35) initial (0), P_IB_ptr ptr, record_quota_overflow condition, pathname char (168), date_time char (24), short_message char (8) aligned, error_message char (100) aligned, segment_created bit (1) initial (""b), state fixed bin (6), num_bits fixed bin (24), num_bytes fixed bin (24), mode_string char (4) varying, reference_offset fixed bin (24), pointer_expression char (24) varying, pointer_name char (8), reference_pointer char (8), reference_pointer_value fixed bin (24), token_len fixed bin (24), reply_code char (3); declare 1 ftp_data aligned like ftp_data_template defined (P_IB_ptr -> ftp_data_template); declare /* T__y_p_e_s M__o_d_e_s R__e_q_u_e_s_t_s N_C_P_ O__r_d_e_r_s */ ((ASCII, Stream, Retrieve) initial (1), (Image, Text, Store) initial (2), (Local_Byte, Block, Append) initial (3), Mail initial (4), Open initial (5), Read initial (6), Write initial (7), Seek initial (8), Close initial (9), List initial (10)) fixed bin internal static options (constant); declare Directory bit (2) initial ("10"b); declare (error_table_$moderr, error_table_$badcall, error_table_$segknown, error_table_$net_invalid_state, error_table_$badstar, error_table_$net_socket_closed, error_table_$incorrect_access, error_table_$namedup, error_table_$noentry, error_table_$net_fhost_inactive, error_table_$net_fhost_down, error_table_$net_fimp_down) external fixed bin (35); %include ftp_server_data; declare request_name (9) char (4) internal static options (constant) initial ("RETR", "STOR", "APPE", "MLFL", "OPEN", "READ", "WRIT", "SEEK", "CLOS"); declare 1 branch aligned, (2 type bit (2), 2 nnames bit (16), 2 nrp bit (18), 2 dtm bit (36), 2 dtu bit (36), 2 mode bit (5), 2 padding bit (13), 2 records bit (18), 2 dtd bit (36), 2 dtem bit (36), 2 acct bit (36), 2 curlen bit (12), 2 bitcnt bit (24), 2 more bit (72)) unaligned; declare event_message (4) fixed bin (71); declare upper_case char (26) internal static options (constant) initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"), lower_case char (26) internal static options (constant) initial ("abcdefghijklmnopqrstuvwxyz"); declare ioa_$ioa_switch entry options (variable), com_err_ entry options (variable), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)), clock_ entry returns (fixed bin (71)), date_time_ entry (fixed bin (71), char (*)), ftp_initialization_$socket_init entry (ptr, fixed bin (35)), ftp_read_ascii_ entry (ptr, fixed bin (24), bit (36), fixed bin (71), fixed bin (24), fixed bin, fixed bin (35)), ftp_read_ascii_$read_with_count entry (ptr, fixed bin (24), fixed bin (24), bit (36), fixed bin (71), fixed bin (24), fixed bin, fixed bin (35)), ftp_write_ascii_ entry (ptr, fixed bin (24), fixed bin (24), bit (36), fixed bin (71), fixed bin, fixed bin (35)), ftp_read_image_ entry (ptr, fixed bin (24), bit (36), fixed bin (71), fixed bin (24), fixed bin, fixed bin (8), fixed bin (35)), ftp_read_image_$read_with_count entry (ptr, fixed bin (24), fixed bin (24), bit (36), fixed bin (71), fixed bin (24), fixed bin, fixed bin (8), fixed bin (35)), ftp_write_image_ entry (ptr, fixed bin (24), fixed bin (24), bit (36), fixed bin (71), fixed bin, fixed bin (8), fixed bin (35)), hcs_$status_long entry (char (*), char (*), fixed bin, ptr, ptr, fixed bin (35)), hcs_$delentry_seg entry (ptr, fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), ncp_$close_connection entry (bit (36), fixed bin (6), fixed bin (35)), ncp_$set_bytesize entry (bit (36), fixed bin (8), fixed bin (35)), check_fs_errcode_ entry (fixed bin (35), char (8) aligned, char (100) aligned), ncp_$initiate_connection entry (bit (36), fixed bin (16), fixed bin (32), fixed bin (6), fixed bin (35)), ncp_$get_socket_state entry (bit (36), fixed bin (6), fixed bin (35)), ipc_$block entry (ptr, ptr, fixed bin (35)); declare (addr, binary, substr, search, divide, null, index, verify, translate) builtin; call com_err_ (error_table_$badcall, "file_transfer", "Command not implemented yet; use FTP server environment."); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ open: entry (P_IB_ptr,argument); declare argument char (*) varying; ftp_data.request = Open; token_len = index (argument, " "); if token_len = 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "502 Mode or pathname for OPEN request missing."); return; end; mode_string = substr (argument, 1, token_len - 1); ftp_data.fap_modes = "00000"b; if search (mode_string, "Rr") ^= 0 then substr (ftp_data.fap_modes, 2, 1) = "1"b; if search (mode_string, "Ww") ^= 0 then substr (ftp_data.fap_modes, 4, 1) = "1"b; if verify (mode_string, "RrWw") ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Bad syntax in mode string. ""^a""", mode_string); return; end; pathname = substr (argument, token_len + (verify (substr (argument, token_len + 1), " "))); call check_ftp_parameters (); call open_file (ftp_data.fap_modes); call initialize_sockets (); ftp_data.fap_read_bit, ftp_data.fap_write_bit = 0; ftp_data.fap_file_is_open = "1"b; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200- ^a>^a open for ^a^/200 in ^a ^d-bit ^a.", ftp_data.dirname, ftp_data.ename, mode_string, mode_name (ftp_data.transfer_mode), ftp_data.byte_size, type_name (ftp_data.representation_type)); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ read: entry (P_IB_ptr,argument); ftp_data.request = Read; call check_for_open_file ("01000"b, "read"); if ftp_data.fap_read_bit = ftp_data.fap_last_bit then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "458 Cannot read; read pointer is at end of file."); return; end; num_bytes = cv_dec_check_ ((argument), code); if code ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Argument ""^a"" to READ request is not a number.", argument); return; end; if num_bytes <= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "502 Request to read ^d bytes is invalid.", num_bytes); return; end; num_bits = num_bytes * ftp_data.byte_size; if ftp_data.fap_read_bit + num_bits > ftp_data.fap_last_bit then num_bits = ftp_data.fap_last_bit - ftp_data.fap_read_bit; call open_data_socket (ftp_data.foreign_read_socket, ftp_data.local_write_socket, ftp_data.write_index); ftp_data.abort_procedure = read_abort; call ioa_$ioa_switch (ftp_data.iocb_ptr, "250 Transfer started."); call write_data (num_bits); if ftp_data.fap_read_bit = ftp_data.fap_last_bit then do; call report_transfer_complete (); call close_data_socket (ftp_data.write_index); end; else if code = 0 then call ioa_$ioa_switch (ftp_data.iocb_ptr, "252 Transfer complete."); ftp_data.abort_procedure = null_abort; return; read_abort: procedure; call close_data_socket (ftp_data.write_index); ftp_data.abort_procedure = null_abort; end read_abort; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ write: entry (P_IB_ptr,argument); ftp_data.request = Write; call check_for_open_file ("00010"b, "writ"); num_bytes = cv_dec_check_ ((argument), code); if code ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Argument ""^a"" to WRIT request is not a number.", argument); return; end; if num_bytes <= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "502 Request to write ^d bytes is invalid.", num_bytes); return; end; call open_data_socket (ftp_data.foreign_write_socket, ftp_data.local_read_socket, ftp_data.read_index); ftp_data.abort_procedure = write_abort; call ioa_$ioa_switch (ftp_data.iocb_ptr, "250 Transfer begun."); call read_data (num_bytes * ftp_data.byte_size); ftp_data.abort_procedure = null_abort; call ioa_$ioa_switch (ftp_data.iocb_ptr, "252 Transfer complete."); return; write_abort: procedure; call close_data_socket (ftp_data.read_index); call update_write_pointer (); ftp_data.abort_procedure = null_abort; end write_abort; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ seek: entry (P_IB_ptr,argument); ftp_data.request = Seek; token_len = index (argument, " "); if token_len = 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "502 Incorrect number of parameters for SEEK request."); return; end; pointer_name = translate (substr (argument, 1, token_len - 1), upper_case, lower_case); pointer_expression = substr (argument, token_len + 1); token_len = search (pointer_expression, "+-"); if token_len = 0 then do; reference_pointer = translate (pointer_expression, upper_case, lower_case); reference_offset = 0; end; else do; reference_pointer = translate (substr (pointer_expression, 1, token_len - 1), upper_case, lower_case); reference_offset = cv_dec_check_ (substr (pointer_expression, token_len + 1), code); if code ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Invalid integer expression in SEEK parameter: ""^a""", substr (pointer_expression, token_len + 1)); return; end; end; if pointer_name = "READ" | reference_pointer = "READ" then call check_for_open_file ("01000"b, "read"); if pointer_name = "WRITE" | reference_pointer = "WRITE" then call check_for_open_file ("00010"b, "writ"); if reference_pointer = "FIRST" then reference_pointer_value = 0; else if reference_pointer = "READ" then reference_pointer_value = ftp_data.fap_read_bit; else if reference_pointer = "WRITE" then reference_pointer_value = ftp_data.fap_write_bit; else if reference_pointer = "LAST" then reference_pointer_value = ftp_data.fap_last_bit; else do; pointer_name = reference_pointer; bad_pointer_name: call ioa_$ioa_switch (ftp_data.iocb_ptr, "502 Invalid pointer name ""^a"" given to SEEK request.", pointer_name); return; end; reference_pointer_value = reference_pointer_value + ftp_data.byte_size * reference_offset; if reference_pointer_value < 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "503 Attempt to assign negative value to ^a pointer.", pointer_name); return; end; if pointer_name = "READ" then if reference_pointer_value > ftp_data.fap_last_bit then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "503 Attempt to set READ pointer beyond end of file."); return; end; else do; ftp_data.fap_read_bit = reference_pointer_value; if ftp_data.fap_read_bit = ftp_data.fap_last_bit then call close_data_socket (ftp_data.write_index); end; else if pointer_name = "WRITE" then ftp_data.fap_write_bit = reference_pointer_value; else if pointer_name = "FIRST" | pointer_name = "LAST" then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "502 Illegal attempt to set ""^a"" pointer with SEEK request.", pointer_name); return; end; else go to bad_pointer_name; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 ^a pointer set.", pointer_name); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ close: entry (P_IB_ptr); ftp_data.request = Close; call check_for_open_file ("00000"b, "clos"); call close_data_socket (ftp_data.read_index); call close_data_socket (ftp_data.write_index); call close_file (); ftp_data.fap_file_is_open = "0"b; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 ^a>^a closed.", ftp_data.dirname, ftp_data.ename); return; retrieve: entry (P_IB_ptr,argument); ftp_data.request = Retrieve; pathname = argument; call check_ftp_parameters (); ftp_data.abort_procedure = retrieve_abort; call open_file ("01000"b); call initialize_sockets (); call open_data_socket (ftp_data.foreign_read_socket, ftp_data.local_write_socket, ftp_data.write_index); call report_start_of_transfer ("to"); call write_data (ftp_data.initial_bit_count); call report_transfer_complete (); call close_data_socket (ftp_data.write_index); call close_file (); ftp_data.abort_procedure = null_abort; return; retrieve_abort: procedure; call close_data_socket (ftp_data.write_index); call close_file (); ftp_data.abort_procedure = null_abort; end retrieve_abort; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ store: entry (P_IB_ptr,argument); ftp_data.request = Store; pathname = argument; call check_ftp_parameters (); ftp_data.abort_procedure = store_abort; call open_file ("00010"b); ftp_data.fap_last_bit = 0; /* remember to truncate the file when done */ go to store_common; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ append: entry (P_IB_ptr,argument); ftp_data.request = Append; pathname = argument; call check_ftp_parameters (); ftp_data.abort_procedure = store_abort; call open_file ("00010"b); ftp_data.fap_write_bit = ftp_data.fap_last_bit; store_common: call initialize_sockets (); call open_data_socket (ftp_data.foreign_write_socket, ftp_data.local_read_socket, ftp_data.read_index); call report_start_of_transfer ("from"); on record_quota_overflow go to record_quota_overflow_handler; call read_data (-1); revert record_quota_overflow; call report_transfer_complete (); call close_file (); ftp_data.abort_procedure = null_abort; return; record_quota_overflow_handler: call ioa_$ioa_switch (ftp_data.iocb_ptr, "453 Record quota overflow in ^a. Cannot complete transfer of ^a.", ftp_data.dirname, ftp_data.ename); call store_abort (); return; store_abort: procedure; call close_data_socket (ftp_data.read_index); call update_write_pointer (); call close_file (); ftp_data.abort_procedure = null_abort; end store_abort; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ mail_transfer: entry (P_IB_ptr, mail_seg_ptr, char_count, error_code); declare mail_seg_ptr pointer, char_count fixed bin, error_code fixed bin (35); ftp_data.request = Mail; ftp_data.segptra = mail_seg_ptr; ftp_data.fap_write_bit, ftp_data.fap_last_bit, ftp_data.initial_bit_count = 0; call check_ftp_parameters (); call initialize_sockets (); ftp_data.abort_procedure = mail_abort; call open_data_socket (ftp_data.foreign_write_socket, ftp_data.local_read_socket, ftp_data.read_index); call ioa_$ioa_switch (ftp_data.iocb_ptr, "250 Begin mail transfer."); call read_data (-1); ftp_data.abort_procedure = null_abort; char_count = divide (ftp_data.fap_write_bit, 9, 17, 0); error_code = code; return; mail_abort: procedure; call close_data_socket (ftp_data.read_index); ftp_data.abort_procedure = null_abort; end mail_abort; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ list_transfer: entry (P_IB_ptr, text_pointer, text_count); declare text_pointer pointer, text_count fixed bin; ftp_data.request = List; ftp_data.segptra = text_pointer; ftp_data.fap_read_bit = 0; call check_ftp_parameters (); call initialize_sockets (); ftp_data.abort_procedure = list_abort; call open_data_socket (ftp_data.foreign_read_socket, ftp_data.local_write_socket, ftp_data.write_index); call ioa_$ioa_switch (ftp_data.iocb_ptr, "250 Begin list transfer."); call write_data (text_count * 9); ftp_data.abort_procedure = null_abort; call ioa_$ioa_switch (ftp_data.iocb_ptr, "252 List transfer complete."); call close_data_socket (ftp_data.write_index); return; list_abort: procedure; call close_data_socket (ftp_data.write_index); ftp_data.abort_procedure = null_abort; end list_abort; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ abort: entry (P_IB_ptr); /* Called by ftp_command_processor_ to abort transfer. */ declare abort_procedure entry variable; abort_procedure = ftp_data.abort_procedure; if ftp_data.read_index ^= ""b /* If no socket created, no useful aborting to do (Almost). */ then call abort_procedure (); /* This is an entry variable -- it'll do the right thing. */ return; status: entry (P_IB_ptr); call date_time_ (clock_ (), date_time); if ftp_data.request = Mail | ftp_data.request = List then do; if ftp_data.request = Mail then short_message = "Mail"; else short_message = "List"; call ioa_$ioa_switch (ftp_data.iocb_ptr, "110 ^a transfer ^a ^a in ^a ^d-bit ^a in progress at ^a.", short_message, ftp_data.word, ftp_data.foreign_host_name, mode_name (ftp_data.transfer_mode), ftp_data.byte_size, type_name (ftp_data.representation_type), substr (date_time, 11, 6)); end; else call ioa_$ioa_switch (ftp_data.iocb_ptr, "110- ^a of ^a>^a ^a ^a^/110 in ^a ^d-bit ^a in progress at ^a.", request_name (ftp_data.request), ftp_data.dirname, ftp_data.ename, ftp_data.word, ftp_data.foreign_host_name, mode_name (ftp_data.transfer_mode), ftp_data.byte_size, type_name (ftp_data.representation_type), substr (date_time, 11, 6)); return; check_ftp_parameters: procedure (); if ftp_data.fap_file_is_open then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "504 A file is already open for File Access Protocol transfer."); go to error_return; end; if ftp_data.representation_type = ASCII then if ftp_data.byte_size = 8 then return; else go to bad_bytesize; else if ftp_data.representation_type = Local_Byte then if ftp_data.byte_size = 9 then go to check_mode; else if ftp_data.byte_size ^= 36 then go to bad_bytesize; check_mode: if ftp_data.transfer_mode = Text then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "505 Text transfer mode is incompatible with ^a representation type.", type_name (ftp_data.representation_type)); go to error_return; end; else return; bad_bytesize: call ioa_$ioa_switch (ftp_data.iocb_ptr, "505 Current byte size ^d is incompatible with ^a representation type.", ftp_data.byte_size, type_name (ftp_data.representation_type)); go to error_return; end check_ftp_parameters; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ open_file: procedure (mode_bits); declare mode_bits bit (5); call expand_pathname_ (pathname, ftp_data.dirname, ftp_data.ename, code); if code ^=0 then go to bad_path; if search (ftp_data.ename, "*=") ^= 0 then do; code = error_table_$badstar; go to bad_path; end; call hcs_$status_long (ftp_data.dirname, ftp_data.ename, 1, addr (branch), null, code); if code ^= 0 then if code = error_table_$noentry then if substr (mode_bits, 4, 1) then do; ftp_data.initial_bit_count = 0; call hcs_$make_seg (ftp_data.dirname, ftp_data.ename, "", 1110b, ftp_data.segptra, code); if code = 0 then segment_created = "1"b; else go to error_reply; end; else go to error_reply; else go to error_reply; else if branch.type = Directory then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "451 ^a>^a is a directory, not a segment.", ftp_data.dirname, ftp_data.ename); go to error_return; end; else do; ftp_data.initial_bit_count = binary (branch.bitcnt, 24); if (branch.mode & mode_bits) ^= mode_bits then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "451 Incorrect access to ^a>^a.", ftp_data.dirname, ftp_data.ename); go to error_return; end; call hcs_$initiate (ftp_data.dirname, ftp_data.ename, "", 0, 0, ftp_data.segptra, code); if code ^= 0 then if code ^= error_table_$segknown then go to error_reply; end; ftp_data.fap_last_bit = ftp_data.initial_bit_count; ftp_data.fap_read_bit, ftp_data.fap_write_bit = 0; end open_file; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ initialize_sockets: procedure; if ftp_data.read_index = ""b then do; call ftp_initialization_$socket_init (addr (ftp_data), code); if code ^= 0 then if code = 1 /* Special error code, error message already printed. */ then go to error_return; else go to net_error; end; end initialize_sockets; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_for_open_file: procedure (desired_mode, action); declare desired_mode bit (5), action char (*); if ^ ftp_data.fap_file_is_open then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "504 No file is open."); go to error_return; end; if (ftp_data.fap_modes & desired_mode) ^= desired_mode then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "503 File is not open for ^aing.", action); go to error_return; end; end check_for_open_file; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ open_data_socket: procedure (foreign_socket, local_socket, socket_index); declare foreign_socket fixed bin (32), local_socket fixed bin (32), socket_index bit (36); call ncp_$get_socket_state (socket_index, state, code); if code ^= 0 then go to net_error; if state = 6 | state = 11 then return; call wait_for_state_change (7); if state ^= 1 then go to bad_state; call ioa_$ioa_switch (ftp_data.iocb_ptr, "255 SOCK ^d", local_socket); call ncp_$set_bytesize (socket_index, ftp_data.byte_size, code); if code ^= 0 then go to net_error; call ncp_$initiate_connection (socket_index, ftp_data.foreign_host, foreign_socket, state, code); if code ^= 0 then go to net_error; call wait_for_state_change (5); if state = 6 | state = 11 then return; if state = 1 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "454 Data connection refused by ^a.", ftp_data.foreign_host_name); code = error_table_$net_invalid_state; go to error_return; end; bad_state: call ioa_$ioa_switch (ftp_data.iocb_ptr, "454 Unable to establish data connection to ^a (Multics NCP state ^d).", ftp_data.foreign_host_name, state); call ncp_$close_connection (socket_index, state, code); go to error_return; wait_for_state_change: procedure (starting_state); declare starting_state fixed bin; declare 1 wait_list aligned automatic, 2 count fixed binary (17) initial (1), 2 channel fixed binary (71) initial (ftp_data.event_channel); do while (state = starting_state); call ipc_$block (addr (wait_list), addr (event_message), code); call ncp_$get_socket_state (socket_index, state, code); if code ^= 0 then go to net_error; end; end wait_for_state_change; end open_data_socket; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ report_start_of_transfer: procedure (which_way); declare which_way char (*); call ioa_$ioa_switch (ftp_data.iocb_ptr, "250- Beginning transfer of ^a>^a^/250 ^a ^a in ^a ^d-bit ^a.", ftp_data.dirname, ftp_data.ename, which_way, ftp_data.foreign_host_name, mode_name (ftp_data.transfer_mode), ftp_data.byte_size, type_name (ftp_data.representation_type)); end report_start_of_transfer; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ write_data: procedure (bits_to_write); declare bits_to_write fixed bin (24); ftp_data.word = "to"; if ftp_data.representation_type = ASCII then call ftp_write_ascii_ (ftp_data.segptra, ftp_data.fap_read_bit, bits_to_write, ftp_data.write_index, ftp_data.event_channel, ftp_data.transfer_mode, code); else call ftp_write_image_ (ftp_data.segptra, ftp_data.fap_read_bit, bits_to_write, ftp_data.write_index, ftp_data.event_channel, ftp_data.transfer_mode, ftp_data.byte_size, code); call check_ftp_io_error_code (); ftp_data.fap_read_bit = ftp_data.fap_read_bit + bits_to_write; end write_data; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ read_data: procedure (bits_to_read); declare bits_to_read fixed bin (24); ftp_data.word = "from"; if bits_to_read = -1 /* Read all there is, then stop. */ then if ftp_data.representation_type = ASCII then call ftp_read_ascii_ (ftp_data.segptra, ftp_data.fap_write_bit, ftp_data.read_index, ftp_data.event_channel, ftp_data.bits_read, ftp_data.transfer_mode, code); else call ftp_read_image_ (ftp_data.segptra, ftp_data.fap_write_bit, ftp_data.read_index, ftp_data.event_channel, ftp_data.bits_read, ftp_data.transfer_mode, ftp_data.byte_size, code); else if ftp_data.representation_type = ASCII then call ftp_read_ascii_$read_with_count (ftp_data.segptra, ftp_data.fap_write_bit, bits_to_read, ftp_data.read_index, ftp_data.event_channel, ftp_data.bits_read, ftp_data.transfer_mode, code); else call ftp_read_image_$read_with_count (ftp_data.segptra, ftp_data.fap_write_bit, bits_to_read, ftp_data.read_index, ftp_data.event_channel, ftp_data.bits_read, ftp_data.transfer_mode, ftp_data.byte_size, code); call check_ftp_io_error_code (); call update_write_pointer (); end read_data; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ update_write_pointer: procedure (); ftp_data.fap_write_bit = ftp_data.fap_write_bit + ftp_data.bits_read; if ftp_data.fap_write_bit > ftp_data.fap_last_bit then ftp_data.fap_last_bit = ftp_data.fap_write_bit; end update_write_pointer; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_ftp_io_error_code: procedure; if code ^= 0 then if code = error_table_$net_invalid_state | code = error_table_$net_socket_closed then call ioa_$ioa_switch (ftp_data.iocb_ptr, "452 Data socket closed prematurely by ^a; transfer incomplete.", ftp_data.foreign_host_name); else do; call check_fs_errcode_ (code, short_message, error_message); call ioa_$ioa_switch (ftp_data.iocb_ptr, "452 ^a Cannot complete transfer.", error_message); end; end check_ftp_io_error_code; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ report_transfer_complete: procedure; if code = 0 then call ioa_$ioa_switch (ftp_data.iocb_ptr, "252 Transfer complete."); end report_transfer_complete; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ close_data_socket: procedure (socket_index); declare socket_index bit (36); call ncp_$get_socket_state (socket_index, state, code); if code = 0 then if state ^= 1 then call ncp_$close_connection (socket_index, state, code); end close_data_socket; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ close_file: procedure (); if ftp_data.fap_last_bit ^= ftp_data.initial_bit_count then do; call hcs_$set_bc_seg (ftp_data.segptra, ftp_data.fap_last_bit, code); if ftp_data.fap_last_bit < ftp_data.initial_bit_count then call hcs_$truncate_seg (ftp_data.segptra, divide (ftp_data.fap_last_bit + 35, 36, 17, 0), code); end; call hcs_$terminate_noname (ftp_data.segptra, code); end close_file; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ null_abort: procedure; /* Nothing to it! */ end null_abort; error_reply: if code = error_table_$moderr | code = error_table_$incorrect_access then reply_code = "451"; else if segment_created then call hcs_$delentry_seg (ftp_data.segptra, code); else if code = error_table_$namedup then reply_code = "456"; else if code = error_table_$noentry then reply_code = "450"; else reply_code = "451"; call check_fs_errcode_ (code, short_message, error_message); call ioa_$ioa_switch (ftp_data.iocb_ptr, "^a ^a ^a>^a", reply_code, error_message, ftp_data.dirname, ftp_data.ename); error_return: if ftp_data.request = Mail then if code = 0 then error_code = 1; else error_code = code; return; bad_path: call check_fs_errcode_ (code, short_message, error_message); call ioa_$ioa_switch (ftp_data.iocb_ptr, "550 ^a ^a", error_message, pathname); go to error_return; net_error: if code = error_table_$net_fhost_inactive | code = error_table_$net_fhost_down | code = error_table_$net_fimp_down then reply_code = "454"; else reply_code = "452"; call check_fs_errcode_ (code, short_message, error_message); if ftp_data.request = Mail then do; error_code = code; call ioa_$ioa_switch (ftp_data.iocb_ptr, "^a ^a Cannot initiate mail transfer from ^a.", reply_code, error_message, ftp_data.foreign_host_name); end; else if ftp_data.request = List then call ioa_$ioa_switch (ftp_data.iocb_ptr, "^a ^a Cannot initiate list transfer to ^a.", reply_code, error_message, ftp_data.foreign_host_name); else do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "^a- ^a Cannot initiate transfer of ^a ^a>^a.", reply_code, error_message, reply_code, ftp_data.dirname, ftp_data.ename); call hcs_$terminate_noname (ftp_data.segptra, code); end; end file_transfer_;  ftp_change_modes_.pl1 09/23/77 1031.6rew 09/22/77 1725.1 70929 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ ftp_change_modes_: procedure (P_IB_ptr, which, argument); /* A Pogran Program 02/06/73 This module implements the MODE, TYPE, STRU, FORM, BYTE, and SOCK commands of the File Transfer Protocol. Note that at this time, Structured Files and ANSI print format are not supported by the Multics FTP-server. Last modified by Ken Pogran 02/23/73 */ declare which char (*), P_IB_ptr ptr, argument char (*) varying; declare 1 ftp_data aligned like ftp_data_template defined (P_IB_ptr -> ftp_data_template); declare new_byte_size fixed bin, code fixed bin (35), comma_pos fixed bin, new_host fixed bin (16), new_socket fixed bin (32), new_type fixed bin, new_mode fixed bin; %include ftp_server_data; declare ioa_$ioa_switch entry options (variable), convert_binary_integer_$decimal_string entry (fixed bin (35)) returns (char (12) varying), cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)), ftp_initialization_$socket_init entry (ptr, fixed bin (35)), host_id_$symbol entry (fixed bin (16), char (*), fixed bin (35)); declare (index, length, mod, substr) builtin; if which = "FORM" then go to set_form; else if which = "STRU" then go to set_structure; else if which = "BYTE" then go to set_byte_size; else if which = "SOCK" then go to set_socket; else if which = "MODE" then go to set_mode; else if which = "TYPE" then go to set_type; call ioa_$ioa_switch (ftp_data.iocb_ptr, "400 ^a command not implemented at this time.", which); /* Why was this routine called for */ return; /* strange command? */ set_form: if argument = "U" | argument = "u" then call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 FORM U accepted."); else if argument = "P" | argument = "p" then call ioa_$ioa_switch (ftp_data.iocb_ptr, "506 Print file format is not implemented at this time."); else go to bad_parameter; return; set_structure: if argument = "F" | argument = "f" then call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 STRU F accepted."); else if argument = "R" | argument = "r" then call ioa_$ioa_switch (ftp_data.iocb_ptr, "506 Record structured files are not implemented at this time."); else go to bad_parameter; return; set_byte_size: new_byte_size = cv_dec_check_ ((argument), code); if code ^= 0 then call ioa_$ioa_switch (ftp_data.iocb_ptr, "503 Argument ""^a"" to BYTE command is not a decimal integer.", argument); else do; ftp_data.byte_size = new_byte_size; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 New byte size is ^d", new_byte_size); end; return; set_socket: if ftp_data.foreign_host = -1 then call ftp_initialization_$socket_init (addr (ftp_data), code); comma_pos = index (argument, ","); if comma_pos ^= 0 then do; new_host = cv_dec_check_ (substr (argument, 1, comma_pos - 1), code); if code ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Bad host specification ""^a"".", substr (argument, 1, comma_pos - 1)); return; end; new_socket = cv_dec_check_ (substr (argument, comma_pos + 1), code); if code ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Bad socket specification ""^a"".", substr (argument, comma_pos + 1)); return; end; new_socket = new_socket - mod (new_socket, 2); ftp_data.foreign_host = new_host; ftp_data.foreign_read_socket = new_socket; ftp_data.foreign_write_socket = new_socket + 1; call host_id_$symbol (new_host, ftp_data.foreign_host_name, code); if code ^= 0 then ftp_data.foreign_host_name = "host " || convert_binary_integer_$decimal_string ((new_host)); call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 New data socket is ^d at ^a.", new_socket, ftp_data.foreign_host_name); end; else do; new_socket = cv_dec_check_ ((argument), code); if code ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Bad socket specification ""^a"".", argument); return; end; new_socket = new_socket - mod (new_socket, 2); ftp_data.foreign_read_socket = new_socket; ftp_data.foreign_write_socket = new_socket + 1; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 New data socket is ^d.", new_socket); end; return; set_type: if length (argument) ^= 1 then go to bad_parameter; new_type = index ("AILE", argument); if new_type = 0 then do; new_type = index ("aile", argument); if new_type = 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Unrecognized representation type ""^a"".", argument); return; end; end; if new_type = 4 then call ioa_$ioa_switch (ftp_data.iocb_ptr, "506 EBCDIC is not supported on Multics at this time."); else do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 New representation type is ^a.", type_name (new_type)); ftp_data.representation_type = new_type; end; return; set_mode: if length (argument) ^= 1 then go to bad_parameter; new_mode = index ("STB", argument); if new_mode = 0 then do; new_mode = index ("stb", argument); if new_mode = 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Unrecognized transfer mode ""^a"".", argument); return; end; end; ftp_data.transfer_mode = new_mode; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 New transfer mode is ^a.", mode_name (new_mode)); return; bad_parameter: call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Bad parameter ""^a"" to ^a command.", argument, which); end ftp_change_modes_;  ftp_command_processor_.pl1 12/19/78 1640.9rew 12/19/78 1637.5 141426 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ ftp_command_processor_: procedure (P_IB_ptr, command_line, quit_flag); /* A Pogran Program 01/20/73 This module provides the command processor for the server File Transfer facility. In addition to merely processing commands, it checks for invalid command sequences, etc. Modified to handle special commands for development by Ken Pogran, 09/18/74 Modified for File Access Protocol commands by Ken Pogran, 10/25/74 Modified to implement NLST by Ken Pogran, 3/4/75 */ /* modified July 1976 to handle two new commands to permit dprinting - XDPP: to send the dprint parameters, and XDPR: to actually request the printing. N.Federman */ /* Modified to implement XSEN, XMAS, and XSEM by C. Hornig, 8/21/78 */ declare command_line char (*), P_IB_ptr ptr, quit_flag bit (1); declare 1 ftp_data aligned like ftp_data_template defined (P_IB_ptr -> ftp_data_template); declare command_length fixed bin (24), command char (4), i fixed bin, argument char (168) varying, arg_length fixed bin (24), arg_begin fixed bin (24), arg_end fixed bin (24); declare command_names (40) char (4) internal static options (constant) initial ("ABOR", "NOOP", "HELP", "REIN", "BYE", "STAT", /* These commands valid after SYNC */ "QUOT", "NQUO", "USER", "PASS", "ACCT", "CLOS", /* These and preceeding commands do not need argument */ "BYTE", "SOCK", "TYPE", "STRU", "MODE", "FORM", "REST", "LSTN", "ALLO", "RNFR", "RNTO", "DELE", "OPEN", "SEEK", /* Commands on these three lines may not be aborted. */ "MAIL", "MLFL", "NLST", "LIST", "RETR", "STOR", "APPE", "READ", "WRIT", "XSEN", "XSEM", "XMAS", /* Commands on these two lines can be ABORted. */ "XDPP", "XDPR" ); /* Commands to DPRINT a file */ declare upper_case char (26) internal static options(constant) initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); declare lower_case char (26) internal static options(constant) initial ("abcdefghijklmnopqrstuvwxyz"); declare ioa_$ioa_switch entry options (variable), ftp_fs_commands_$XDPP entry (ptr, char(*) varying), ftp_fs_commands_$XDPR entry (ptr, char(*) varying), ftp_server_listen_$bye entry (ptr, bit (1)), ftp_fs_commands_$delete entry (ptr, char (*) varying), file_transfer_$status entry (ptr), file_transfer_$abort entry (ptr), file_transfer_$open entry (ptr, char (*) varying), file_transfer_$read entry (ptr, char (*) varying), file_transfer_$write entry (ptr, char (*) varying), file_transfer_$seek entry (ptr, char (*) varying), file_transfer_$close entry (ptr), ftp_change_modes_ entry (ptr, char (*), char (*) varying), ftp_mail_ entry (ptr, char (*), char (*) varying), ftp_mail_$abort entry (ptr), ftp_server_status_$list entry (ptr, char (*) varying), ftp_server_status_$namelist entry (ptr, char (*) varying), ftp_server_status_ entry (ptr, char (*) varying), ftp_fs_commands_$rename_from entry (ptr, char (*) varying), ftp_fs_commands_$rename_to entry (ptr, char (*) varying), file_transfer_$retrieve entry (ptr, char (*) varying), file_transfer_$store entry (ptr, char (*) varying), file_transfer_$append entry (ptr, char (*) varying); declare dev_file_transfer_ entry (ptr, char (*)); declare (substr, index, hbound, length, reverse, translate, verify) builtin; %include ftp_server_data; command_length = index (command_line, " ") - 1; if command_length = -1 then do; command = command_line; command_length = length (command_line); end; else command = substr (command_line, 1, command_length); command = translate (command, upper_case, lower_case); if command_length >4 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Command name longer than four characters: ""^a""", translate (substr (command_line, 1, command_length), upper_case, lower_case)); return; end; if ftp_data.rename_in_progress then if command ^= "RNTO" then do; ftp_data.rename_in_progress = "0"b; call ioa_$ioa_switch (ftp_data.iocb_ptr, "505 RNFR must be followed by RNTO."); return; end; else do; ftp_data.last_command = 23; call get_argument (); go to process_command (23); end; else if quit_flag then do; do i = 1 to 6; if command = command_names (i) then go to process_command (i); end; call ioa_$ioa_switch (ftp_data.iocb_ptr, "504 Only ABOR, NOOP, BYE, REIN, HELP, and STAT are valid after SYNC is received."); if ftp_data.last_command ^= 0 then call ioa_$ioa_switch (ftp_data.iocb_ptr, "050 Processing of ^a resumed.", command_names (ftp_data.last_command)); return; end; else do; do i = 1 to hbound(command_names,1); if command = command_names (i) then go to have_command; end; if command = "XDV1" then go to development_command; if verify (command, " ABCDEFGHIJKLMNOPQRSTUVWXYZ") ^= 0 then call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 Syntax error in command line: ""^a""", command_line); else call ioa_$ioa_switch (ftp_data.iocb_ptr, "500 Unrecognized command: ""^a""", command); return; have_command: ftp_data.last_command = i; if i > 12 then call get_argument (); go to process_command (i); end; process_command (1): /* ABOR */ if ^ quit_flag then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "202 ABOR ignored; no activity in progress at this time."); return; end; if ftp_data.last_command > 26 then do; if ftp_data.last_command = 27 then call ftp_mail_$abort (addr (ftp_data)); else call file_transfer_$abort (addr (ftp_data)); call ioa_$ioa_switch (ftp_data.iocb_ptr, "201 ^a aborted.", command_names (ftp_data.last_command)); goto ftp_data.abort_return_label; end; if ftp_data.last_command ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "504 ^a cannot be aborted.", command_names (ftp_data.last_command)); go to check_return; end; call ioa_$ioa_switch (ftp_data.iocb_ptr, "202 ABOR ignored; no activity in progress at this time."); return; process_command (2): /* NOOP */ call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 No operation."); go to check_return; process_command (3): /* HELP */ process_command (7): /* QUOT */ process_command (8): /* NQUO */ process_command (19): /* REST */ process_command (20): /* LSTN */ call ioa_$ioa_switch (ftp_data.iocb_ptr, "400 ^a command not implemented at this time.", command); go to check_return; process_command (4): /* REIN */ ftp_data.logout_hold = "1"b; process_command (5): /* BYE */ if quit_flag then if ftp_data.last_command ^= 0 then do; ftp_data.bye_pending = "1"b; call ioa_$ioa_switch (ftp_data.iocb_ptr, "232 ^a will be performed when ^a has completed.", command, command_names (ftp_data.last_command)); go to check_return; end; call ftp_server_listen_$bye (addr (ftp_data), ftp_data.logout_hold); ftp_data.logout_hold = "0"b; go to check_return; /* REIN is not permitted for Telnet user who invoked ftp_server */ process_command (6): /* STAT */ if quit_flag then if ftp_data.last_command > 27 then do; call file_transfer_$status (addr (ftp_data)); go to check_return; end; if verify (reverse (command_line), " ") < length (command_line) - command_length then call get_argument (); else argument = ""; call ftp_server_status_ (addr (ftp_data), argument); go to check_return; process_command (9): /* USER */ process_command (10): /* PASS */ call ioa_$ioa_switch (ftp_data.iocb_ptr, "504 ^a command not valid at this time.", command ); go to check_return; process_command (11): /* ACCT */ process_command (21): /* ALLO */ call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 ^a command is not required.", command); go to check_return; process_command (12): /* CLOS */ call file_transfer_$close (addr (ftp_data)); go to check_return; process_command (13): /* BYTE */ process_command (14): /* SOCK */ process_command (15): /* TYPE */ process_command (16): /* STRU */ process_command (17): /* MODE */ process_command (18): /* FORM */ call ftp_change_modes_ (addr (ftp_data), command, argument); go to check_return; process_command (22): /* RNFR */ call ftp_fs_commands_$rename_from (addr (ftp_data), argument); ftp_data.rename_in_progress = "1"b; go to check_return; process_command (23): /* RNTO */ if ^ ftp_data.rename_in_progress then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "504 RNTO must be preceeded by RNFR."); end; else do; call ftp_fs_commands_$rename_to (addr (ftp_data), argument); ftp_data.rename_in_progress = "0"b; end; go to check_return; process_command (24): /* DELE */ call ftp_fs_commands_$delete (addr (ftp_data), argument); go to check_return; process_command (25): /* OPEN */ call file_transfer_$open (addr (ftp_data), argument); go to check_return; process_command (26): /* SEEK */ call file_transfer_$seek (addr (ftp_data), argument); go to check_return; process_command (36): /* XSEN */ process_command (37): /* XSEM */ process_command (38): /* XMAS */ process_command (27): /* MAIL */ process_command (28): /* MLFL */ call ftp_mail_ (addr (ftp_data), command, argument); go to check_return; process_command (29): /* NLST */ call ftp_server_status_$namelist (addr (ftp_data), argument); go to check_return; process_command (30): /* LIST */ call ftp_server_status_$list (addr (ftp_data), argument); go to check_return; process_command (31): /* RETR */ call file_transfer_$retrieve (addr (ftp_data), argument); go to check_return; process_command (32): /* STOR */ call file_transfer_$store (addr (ftp_data), argument); go to check_return; process_command (33): /* APPE */ call file_transfer_$append (addr (ftp_data), argument); go to check_return; process_command (34): /* READ */ call file_transfer_$read (addr (ftp_data), argument); go to check_return; process_command (35): /* WRIT */ call file_transfer_$write (addr (ftp_data), argument); go to check_return; process_command(39) : /* XDPP */ call ftp_fs_commands_$XDPP (addr (ftp_data), argument); go to check_return; process_command(40): /* XDPR */ call ftp_fs_commands_$XDPR (addr (ftp_data), argument); go to check_return; check_return: if quit_flag then if ftp_data.last_command ^= 0 then call ioa_$ioa_switch (ftp_data.iocb_ptr, "051 Processing of ^a resumed.", command_names (ftp_data.last_command)); else; else do; ftp_data.last_command = 0; if ftp_data.bye_pending then do; ftp_data.bye_pending = "0"b; call ftp_server_listen_$bye (addr (ftp_data), ftp_data.logout_hold); /* REIN is not permitted for Telnet */ ftp_data.logout_hold = "0"b; /* user who invoked ftp_server */ end; end; return; development_command: call dev_file_transfer_ (addr (ftp_data), command_line); go to check_return; get_argument: procedure; if length (command_line) = command_length then go to no_argument; arg_begin = verify (substr (command_line, command_length + 2), " ") + command_length; if arg_begin = command_length then go to no_argument; arg_end = verify (reverse (command_line), " "); arg_length = length (command_line) - arg_begin - arg_end + 1; argument = substr (command_line, arg_begin + 1, arg_length); end get_argument; no_argument: call ioa_$ioa_switch (ftp_data.iocb_ptr, "502 Expected argument missing."); end ftp_command_processor_;  ftp_fs_commands_.pl1 09/23/77 1031.6rew 09/22/77 1725.1 163008 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ delete: procedure (P_IB_ptr, argument); declare argument char (*) varying; /* A Pogran Program 01/20/73 This module (ftp_fs_commands_) implements the File Transfer delete (DELE) and rename (RNFR || RNTO) commands. The delete command will unlink links (rather than chasing them and deleting segments) and will not delete directories. Delete acts like the Multics deleteforce command (it is defined this way by the Protocol). Last modified by Ken Pogran 02/13/73 */ /* Modified July 1976 to implement the XDPP and XDPR commands which permit DPRINTing. XDPP is invoked to send the DPRINT parameters while XDPR is used to actually request the printing. N.Federman */ declare delete_entry bit (1) initial ("0"b), pathname char (168), P_IB_ptr ptr, dirname char (168), ename char (32), new_name char (32), reply_code char (3), error_message char (100) aligned, short_message char (8) aligned, code fixed bin (35), count fixed bin (17), eql_name char (32); declare 1 ftp_data aligned like ftp_data_template defined (P_IB_ptr -> ftp_data_template); declare (error_table_$moderr, error_table_$dirseg, error_table_$incorrect_access, error_table_$namedup, error_table_$noentry, error_table_$badstar) external static fixed bin (35); declare expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), check_fs_errcode_ entry ( fixed bin (35), char (8) aligned, char (100) aligned), ioa_$ioa_switch entry options (variable), delete_$path entry ( char (*), char (*), bit (6), char (*), fixed bin (35)), check_star_name_$entry entry (char (*), fixed bin (35)), equal_ entry ( ptr, ptr, ptr, fixed bin (35)), hcs_$chname_file entry ( char (*), char (*), char (*), char (*), fixed bin (35)); declare (addr, hbound, index, length, substr, translate) builtin; /* added declarations */ %include ftp_server_data; %include dprint_arg; dcl parm_names (16) char (4) internal static options (constant) initial ("BLBL", "CARR", "COPY", "DELE", "DEST", "DTYP", "FORM", "HEAD", "LLEN", "MARG", "OUTM", "PLEN", "QEUE", "RSET", "RTYP", "TLBL"); dcl parm char (4); dcl i fixed bin; dcl fixed_bin_arg fixed bin (35); dcl code1 fixed bin; dcl bitcnt fixed bin (24); dcl longinfo char (100) aligned; dcl type fixed bin (2); dcl shortinfo char (8) aligned; dcl (del_acc, read_acc, stat_acc) bit (1) aligned ; dcl ret_accname char (32) aligned; dcl dprint_ entry ( char (*), char (*), ptr, fixed bin (35)); dcl dprint_$qfull entry (fixed bin (17), fixed bin (17), fixed bin (35), char (8)); dcl dprint_$access_check entry ( char (*), char (*), char (8) aligned, bit (1) aligned, bit (1) aligned, bit (1) aligned, char (*) aligned, fixed bin (35)); dcl cv_dec_check_ entry ( char (*), fixed bin) returns (fixed bin (35)); dcl convert_status_code_ entry ( fixed bin (35), char (8) aligned, char (100) aligned); dcl hcs_$status_minf entry ( char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl (error_table_$lock_wait_time_exceeded, error_table_$notalloc) external fixed bin (35); dcl upper_case char (26) internal static options (constant) initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl lower_case char (26) internal static options (constant) initial ("abcdefghijklmnopqrstuvwxyz"); delete_entry = "1"b; pathname = argument; call expand_pathname_ (pathname, dirname, ename, code); if code ^= 0 then go to bad_path; call delete_$path (dirname, ename, "100110"b, "", code); if code ^= 0 then goto interpret_error_code; call ioa_$ioa_switch (ftp_data.iocb_ptr, "254 ^a>^a deleted.", dirname, ename); return; rename_from: entry (P_IB_ptr, argument); pathname = argument; call expand_pathname_ (pathname, dirname, ename, code); if code ^= 0 then go to bad_path; ftp_data.old_dir = dirname; ftp_data.old_name = ename; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 Enter new name."); return; rename_to: entry (P_IB_ptr, argument); if length (argument) > 32 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "550 New entry name ""^a"" longer than 32 characters.", argument); return; end; new_name = argument; call check_star_name_$entry (new_name, code); if code ^= 0 then do; if code = 1 | code = 2 then code = error_table_$badstar; go to bad_path; end; if index (new_name, "=") ^= 0 then do; call equal_ (addr (ftp_data.old_name), addr (new_name), addr (eql_name), code); if code ^= 0 then go to bad_path; new_name = eql_name; end; call hcs_$chname_file (ftp_data.old_dir, ftp_data.old_name, ftp_data.old_name, new_name, code); if code = 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "253 ^a renamed ^a in ^a.", ftp_data.old_name, new_name, ftp_data.old_dir); return; end; interpret_error_code: if code = error_table_$moderr | code = error_table_$incorrect_access | code = error_table_$dirseg then reply_code = "451"; else if code = error_table_$namedup then reply_code = "456"; else if code = error_table_$noentry then reply_code = "450"; else reply_code = "455"; call check_fs_errcode_ (code, short_message, error_message); if delete_entry then call ioa_$ioa_switch (ftp_data.iocb_ptr, "^a ^a ^a>^a", reply_code, error_message, dirname, ename); else call ioa_$ioa_switch (ftp_data.iocb_ptr, "^a ^a Cannot rename ^a to ^a in ^a.", reply_code, error_message, ftp_data.old_name, new_name, ftp_data.old_dir); return; XDPP: entry (P_IB_ptr, argument); if ftp_data.dptr = null () then call reset_proc; /* make sure that data structrure is initialized */ dpap = ftp_data.dptr; parm = substr (argument, 1, 4) ; /* pick up parameter name */ parm = translate (parm, upper_case, lower_case); do i = 1 to hbound (parm_names, 1); if parm = parm_names (i) then goto process_parm (i); end; call ioa_$ioa_switch (ftp_data.iocb_ptr, "500 XDPP unrecognized parameter ^a ", parm); return; reset_proc: proc; if ftp_data.dptr = null () then allocate dprint_arg set(ftp_data.dptr); dpap = ftp_data.dptr; dprint_arg.version = 4; /* reset data structure containing the dprint parameters */ dprint_arg.copies = 1; dprint_arg.delete = 0; dprint_arg.queue = 3; dprint_arg.pt_pch = 1; dprint_arg.notify = 0; dprint_arg.heading = ""; dprint_arg.output_module = 1; dprint_arg.dest = ""; dprint_arg.carriage_control = "0"b; dprint_arg.forms = ""; dprint_arg.lmargin = 0; dprint_arg.line_lth = -1; dprint_arg.class = "printer"; dprint_arg.page_lth = -1; dprint_arg.top_label = ""; dprint_arg.bottom_label = ""; return; end; process_parm (1): /* bottom label */ dprint_arg.bottom_label = substr (argument, 6); call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP bottom label set"); return; process_parm (2): /* carriage control */ if (substr (argument, 6, 1) = "1") then dprint_arg.nep = "1"b; if (substr (argument, 7, 1) = "1") then dprint_arg.single = "1"b; if (substr (argument, 8, 1) = "1") then dprint_arg.non_edited = "1"b; if (substr (argument, 9, 1) = "1") then dprint_arg.truncate = "1"b; if (substr (argument, 10, 1) = "1") then dprint_arg.center_top_label = "1"b; if (substr (argument, 11, 1) = "1") then dprint_arg.center_bottom_label = "1"b; if (substr (argument, 12, 1) = "1") then dprint_arg.padding = "1"b; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP carriage control parameters set"); return; process_parm (3) : /* copies */ fixed_bin_arg = cv_dec_check_ (substr (argument, 6), code1); if code1 ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 XDPP syntax error in copy parameter - invalid value "); return; end; dprint_arg.copies = fixed_bin_arg; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP copies parameter set"); return; process_parm (4): /* delete */ fixed_bin_arg = cv_dec_check_ (substr (argument, 6), code1); if code1 ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 XDPP syntax error in delete parameter - illegal value "); return; end; dprint_arg.delete = fixed_bin_arg; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP delete parameter set "); return; process_parm (5): /* destination */ dprint_arg.dest = substr (argument, 6); call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP destination parameter set"); return; process_parm (6): /* dectype - pt_pch parameter */ fixed_bin_arg = cv_dec_check_ (substr (argument, 6), code1); if code1 ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 XDPP syntax error in device type parameter - illegal value "); return; end; dprint_arg.pt_pch = fixed_bin_arg; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP device type set"); return; process_parm (7): /* form */ dprint_arg.forms = substr (argument, 6); call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP forms parameter set"); return; process_parm (8): /* heading */ dprint_arg.heading = substr (argument, 6); call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP heading set"); return; process_parm (9): /* line length */ fixed_bin_arg = cv_dec_check_ (substr (argument, 6), code1); if code1 ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 XDPP syntax error in line length parameter - illegal value "); return; end; dprint_arg.line_lth = fixed_bin_arg; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP line length set"); return; process_parm (10): /* margin */ fixed_bin_arg = cv_dec_check_ (substr (argument, 6), code1); if code1 ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 XDPP syntax error in margin parameter - illegal value "); return; end; dprint_arg.lmargin = fixed_bin_arg; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP margin set"); return; process_parm (11): /* output_module */ fixed_bin_arg = cv_dec_check_ (substr (argument, 6), code1); if code1 ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 XDPP syntax error in output module parameter - illegal value"); return; end; dprint_arg.output_module = fixed_bin_arg; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP output module parameter set"); return; process_parm (12): /* page_length */ fixed_bin_arg = cv_dec_check_ (substr (argument, 6), code1); if code1 ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 XDPP syntax error in page length parameter - illegal value "); return; end; dprint_arg.page_lth = fixed_bin_arg; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP page length set"); return; process_parm (13): /* queue */ fixed_bin_arg = cv_dec_check_ (substr (argument, 6), code1); if code1 ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "501 XDPP syntax error in queue parameter - illegal value "); return; end; dprint_arg.queue = fixed_bin_arg; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP queue parameter set"); return; process_parm (14): /* reset */ call reset_proc; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP reset complete"); return; process_parm (15): /* request type */ dprint_arg.class = substr (argument, 6); call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 request type set "); return; process_parm (16): /* top_label */ dprint_arg.top_label = substr (argument, 6); call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPP top label parameter set"); return; XDPR: entry (P_IB_ptr, argument); /* where the argument is the pathname of the file to be printed */ if ftp_data.dptr = null () then call reset_proc; /* make sure data structure is initialized */ dpap = ftp_data.dptr; pathname = argument; call expand_pathname_ (pathname, dirname, ename, code); if code ^= 0 then do; call convert_status_code_ (code, shortinfo, longinfo); call ioa_$ioa_switch (ftp_data.iocb_ptr, "450 XDPR ^a ", longinfo); return; end; call hcs_$status_minf (dirname, ename, 1, type, bitcnt, code); /* see if file exists */ if code ^= 0 then do; if code = error_table_$noentry then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "450 XDPR file not found : ^a ^a ", dirname, ename); return; end; call convert_status_code_ (code, shortinfo, longinfo); call ioa_$ioa_switch (ftp_data.iocb_ptr, "450 XDPR ^a ", longinfo); return; end; call dprint_$access_check (dirname, ename, dprint_arg.class, del_acc, read_acc, stat_acc, ret_accname, code); /* check if we have access to the file */ if code ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "451 XDPR unable to check access to file "); return; end; if ^read_acc then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "451 XDPR no read access to file "); return; end; if ^stat_acc then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "451 XDPR no status access to file "); return; end; /* ok, all is well so attempt the grand finale */ call dprint_ (dirname, ename, dpap, code); if code ^= 0 then do; if code = error_table_$lock_wait_time_exceeded then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "451 XDPR timeout while waiting on queue "); return; end; if code = error_table_$noentry then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "503 XDPR request type probably doesn't exist "); return; end; if code = error_table_$notalloc then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "451 XDPR request queue is full "); return; end; call convert_status_code_ (code, shortinfo, longinfo); call ioa_$ioa_switch (ftp_data.iocb_ptr, "451 XDPR ^a ", longinfo); return; end; call dprint_$qfull (dpap -> dprint_arg.queue, count, code, (dpap -> dprint_arg.class)); count = max (0, count - 1); if code ^= 0 then call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 XDPR dprint request completed."); else do; if count = 1 then call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 There is 1 previous request."); else call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 There are ^d previous requests.", count); end; return; bad_path: call check_fs_errcode_ (code, short_message, error_message); call ioa_$ioa_switch (ftp_data.iocb_ptr, "550 ^a ^a", error_message, pathname); end delete;  ftp_initialization_.pl1 09/23/77 1031.6rew 09/22/77 1725.3 61101 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ socket_init: procedure (P_IB_ptr,error_code); declare error_code fixed bin (35); /* A Pogran Program 02/20/73 This module performs the initialization of the local data sockets and event channel for file transfer, and determines the "default foreign socket" if necessary. It also deactivates these sockets and deletes the event channel when the user leaves the FTP server environment. The "command_init" entry point is provided to re-initialize FTP parameters when the FTP server environment is re-entered from command level. Last modified by K. T. Pogran 3/4/75 Last modified by D. M. Wells to not deactivate sockets for normal user, to use sockets S+2 and S+3, and to get rid of 455 reply codes. */ declare code fixed bin (35), P_IB_ptr ptr, net_user_id fixed bin (24), local_pin fixed bin (8), foreign_read_socket bit (41); declare 1 ftp_data aligned like ftp_data_template defined (P_IB_ptr -> ftp_data_template); declare 1 socket_info_struc (0 : 1) aligned automatic, 2 socket_state fixed binary (12), 2 local_socket fixed binary (32), 2 foreign_host fixed binary (16), 2 foreign_socket fixed binary (32); declare hcs_$assign_channel entry (fixed bin (71), fixed bin (35)), ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)), ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), freen_ entry (ptr), ncp_$accept_passoff entry (fixed bin (24), fixed bin, fixed bin (71), bit (36), fixed bin (35)), ncp_$get_userid entry (fixed bin (24), fixed bin (35)), convert_binary_integer_$decimal_string entry (fixed bin) returns (char (12) varying), ioa_$ioa_switch entry options (variable), host_id_$symbol entry (fixed bin (16), char (*), fixed bin (35)), ncp_$detach_socket entry (bit (36), fixed bin (35)); %include ftp_server_data; declare (addr, binary, divide, mod, null, substr) builtin; call hcs_$assign_channel (ftp_data.event_channel, code); if code ^= 0 then do; /* Can't get fast channel. */ call ipc_$create_ev_chn (ftp_data.event_channel, code); if code ^= 0 then go to error_return; end; call iox_$control (ftp_data.iocb_ptr, "get_socket_states", addr (socket_info_struc), code); if code ^= 0 then go to error_return; net_user_id = divide (socket_info_struc (0).local_socket, 256, 24, 0); local_pin = mod (socket_info_struc (0).local_socket, 256); call ncp_$accept_passoff (net_user_id, local_pin + 2, ftp_data.event_channel, ftp_data.read_index, code); if code ^= 0 then go to error_return; call ncp_$accept_passoff (net_user_id, local_pin + 3, ftp_data.event_channel, ftp_data.write_index, code); if code ^= 0 then go to error_return; ftp_data.local_read_socket = socket_info_struc (0).local_socket + 2; ftp_data.local_write_socket = socket_info_struc (0).local_socket + 3; ftp_data.foreign_host = socket_info_struc (0).foreign_host; ftp_data.foreign_read_socket = socket_info_struc (1).foreign_socket + 2; ftp_data.foreign_write_socket = socket_info_struc (0).foreign_socket + 2; call host_id_$symbol (ftp_data.foreign_host, ftp_data.foreign_host_name, code); if code ^= 0 then do; ftp_data.foreign_host_name = "host " || convert_binary_integer_$decimal_string ((ftp_data.foreign_host)); code = 0; /* We must do this or we'll return an error code to caller unwittingly! */ end; error_return: error_code = code; return; init_ftp_data: entry (P_IB_ptr); ftp_data.iocb_ptr = null (); ftp_data.dptr = null (); ftp_data.quit_flag = "0"b; ftp_data.quit_condition = "quit"; ftp_data.event_channel = 0; ftp_data.read_index = ""b; ftp_data.write_index = ""b; ftp_data.foreign_host = -1; ftp_data.foreign_read_socket = -1; ftp_data.foreign_write_socket = -1; ftp_data.local_read_socket = -1; ftp_data.local_write_socket = -1; ftp_data.foreign_host_name = ""; ftp_data.byte_size = 8; ftp_data.representation_type = 1; ftp_data.transfer_mode = 1; ftp_data.fap_file_is_open = "0"b; ftp_data.segptra = null (); ftp_data.segptrb = null (); ftp_data.text_ptr = null (); ftp_data.old_dir = ""; ftp_data.old_name = ""; ftp_data.bye_pending = "0"b; ftp_data.logout_hold = "0"b; ftp_data.last_command = 0; ftp_data.rename_in_progress = "0"b; return; cleanup: entry (P_IB_ptr, server_process); declare server_process bit (1); /* This entry is called by ftp_server_listen_$bye to deactivate data sockets and delete the data socket event channel. */ if server_process then return; /* That's all we need to do; he's about to lose his process */ if ftp_data.read_index ^= ""b then do; call ncp_$detach_socket (ftp_data.read_index, (0)); call ncp_$detach_socket (ftp_data.write_index, (0)); end; if ftp_data.event_channel ^= 0 then do; call ipc_$delete_ev_chn (ftp_data.event_channel, code); ftp_data.event_channel = 0; end; if ftp_data.dptr ^= null () then do; call freen_ (ftp_data.dptr); ftp_data.dptr = null (); end; end;  ftp_mail_.pl1 07/17/81 1758.1rew 07/17/81 1540.2 100269 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */ ftp_mail_: procedure (P_IB_ptr, Which, Argument); declare Which char (*), P_IB_ptr ptr, Argument char (*) varying; declare 1 ftp_data aligned like ftp_data_template defined (P_IB_ptr -> ftp_data_template); /* A Pogran Program 02/22/73 This module implements the network mail commands of the File Transfer Protocol. It performs virtually the same actions as the standard system "mail" command, but speaks to the user in FTP syntax. Also, if it can be determined, the full name of the network host the user is at is included in the message header. Rewritten July 1979 by C. Hornig. */ declare 1 tty_info aligned like terminal_info, code fixed bin (35), line char (128), nelemt fixed bin (21), i fixed bin (21), host fixed bin (16), host_name char (32), anonymous bit (1) aligned, tsegp ptr, old_modes char (512), long_rec bit (1) aligned, type char (4) aligned; dcl 1 saved_mail aligned based (ftp_data.mail_info.segptrb), 2 type char (4), 2 mf aligned like mail_format; declare (cleanup, record_quota_overflow) condition; declare error_table_$long_record fixed bin (35) external; declare error_table_$rqover fixed bin (35) external; declare ioa_$ioa_switch entry options (variable), canonicalize_ entry (ptr, fixed bin (21), ptr, fixed bin (21), fixed bin (35)), convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned), iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), iox_$modes entry (ptr, char (*), char (*), fixed bin (35)), file_transfer_$mail_transfer entry (ptr, ptr, fixed bin (21), fixed bin (35)), host_id_$number entry (fixed bin (16), char (*), fixed bin (35)), host_id_$symbol entry (fixed bin (16), char (*), fixed bin (35)), net_log_ entry options (variable), net_log_$net_error_log entry options (variable), get_temp_segment_ entry (char (*), ptr, fixed (35)), release_temp_segment_ entry (char (*), ptr, fixed (35)), ftp_mail_mailer_ entry (varying char (*), pointer, fixed (35)), ftp_mail_mailer_$validate entry (varying char (*), pointer, fixed (35)); declare (addr, hbound, index, length, null, substr) builtin; /* * * * * * * * * * * * * FTP_MAIL_ * * * * * * * * * */ anonymous = "0"b; goto common; anonymous_mail: entry (P_IB_ptr, Which, Argument); anonymous = "1"b; common: type = Which; old_modes = ""; host_name = "Network"; tty_info.version = terminal_info_version; call iox_$control (ftp_data.iocb_ptr, "terminal_info", addr (tty_info), code); if (code = 0) & (tty_info.line_type = LINE_TELNET) then do; host_name = tty_info.id; call host_id_$number (host, tty_info.id, code); if code = 0 then do; call host_id_$symbol (host, host_name, code); if code ^= 0 then host_name = tty_info.id; end; end; if anonymous then call net_log_ (0, "ftp_mail_: From ^a: ^a ^a", host_name, Which, Argument); tsegp = null (); if /* case */ type = "XRSQ" then do; if /* case */ Argument = "?" then do; ftp_data.mail_info.n_users = 0; if (ftp_data.mail_info.i = 2) & (ftp_data.mail_info.segptrb ^= null ()) then do; call release_temp_segment_ ("ftp_mail_", ftp_data.mail_info.segptrb, code); ftp_data.mail_info.segptrb = null (); end; call ioa_$ioa_switch (ftp_data.iocb_ptr, "215 T Please send the text first."); end; else do; call reset_xrsq; ftp_data.mail_info.i = 0; if /* case */ (Argument = "R") | (Argument = "r") then do; ftp_data.mail_info.i = 1; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 OK, recipients first."); end; else if (Argument = "T") | (Argument = "t") then do; ftp_data.mail_info.i = 2; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 OK, text first."); end; else if Argument = "" then call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 I hack XRSQ."); else call error (501, 0, "XRSQ scheme not implemented"); end; return; end; else if type = "XRCP" then do; if /* case */ ftp_data.mail_info.i = 2 then do; if ftp_data.mail_info.segptrb = null () then call error (507, 0, "No mail to send yet"); mail_format_ptr = addr (saved_mail.mf); call mail_it (saved_mail.type, Argument, code); call reply (saved_mail.type, code); end; else if ftp_data.mail_info.i = 1 then do; call ftp_mail_mailer_$validate (Argument, null (), code); if code ^= 0 then call error (450, code, "Validating address"); if ftp_data.mail_info.n_users >= hbound (ftp_data.mail_info.addressee, 1) then call error (440, 0, "Too many names."); ftp_data.mail_info.n_users = ftp_data.mail_info.n_users + 1; ftp_data.mail_info.addressee (ftp_data.mail_info.n_users).user_name = Argument; call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 Address accepted."); end; else call error (501, 0, "Must use XRSQ first."); return; end; on cleanup begin; if anonymous then call net_log_ (0, "ftp_mail_: Mail attempt aborted."); if tsegp ^= null () then call release_temp_segment_ ("ftp_mail_", tsegp, (0)); end; call get_temp_segment_ ("ftp_mail_", tsegp, code); if tsegp = null () then call error (455, code, "Unable to create workspace."); mail_format_ptr = addr (tsegp -> saved_mail.mf); mail_format.version = mail_format_version_3; mail_format.sent_from = host_name; if Argument ^= "" then do; call reset_xrsq; if type = "XSEN" then mail_format.wakeup = "1"b; call ftp_mail_mailer_$validate (Argument, mail_format_ptr, code); if code ^= 0 then call error (450, code, "Validating destination."); end; if type ^= "MLFL" then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "350 Input"); call iox_$modes (ftp_data.iocb_ptr, "rawi", old_modes, code); long_rec = "0"b; do while ("1"b); call iox_$get_line (ftp_data.iocb_ptr, addr (line), length (line), nelemt, code); if (code = 0) & ^long_rec & (nelemt = 3) & (substr (line, 1, 3) = ". ") then go to have_input; if /* case */ code = 0 then long_rec = "0"b; else if code = error_table_$long_record then long_rec = "1"b; else call error (0, code, "Reading from command stream."); substr (mail_format.text, mail_format.text_len + 1, nelemt) = substr (line, 1, nelemt); mail_format.text_len = mail_format.text_len + nelemt; end; have_input: call iox_$modes (ftp_data.iocb_ptr, old_modes, (""), code); end; else do; call file_transfer_$mail_transfer (addr (ftp_data), addr (mail_format.text), mail_format.text_len, code); if code ^= 0 then call error (0, code, "Unable to receive mail."); end; call canonicalize_ (addr (mail_format.text), mail_format.text_len, addr (mail_format.text), mail_format.text_len, code); if code ^= 0 then call error (0, code, "Error canonicalizing mail text."); i = 1; mail_format.lines = -1; do nelemt = 1 repeat (nelemt + i) while ((i > 0) & (nelemt <= mail_format.text_len + 1)); mail_format.lines = mail_format.lines + 1; i = index (substr (mail_format.text, nelemt), " "); end; if /* case */ Argument ^= "" then do; call mail_it (type, Argument, code); call reply (type, code); end; else if ftp_data.mail_info.i = 2 then do; if ftp_data.mail_info.segptrb ^= null () then call release_temp_segment_ ("ftp_mail_", ftp_data.mail_info.segptrb, code); ftp_data.mail_info.segptrb = tsegp; tsegp = null (); saved_mail.type = type; call ioa_$ioa_switch (ftp_data.iocb_ptr, "256 Mail stored."); return; end; else if (ftp_data.mail_info.n_users <= 0) | (ftp_data.mail_info.i ^= 1) then call error (450, 0, "No recipients given."); else do; do i = 1 to ftp_data.mail_info.n_users; call mail_it (type, ftp_data.mail_info.addressee (i).user_name, code); end; call reply (type, 0); ftp_data.mail_info.n_users = 0; end; close_all_boxes: if tsegp ^= null () then call release_temp_segment_ ("ftp_mail_", tsegp, code); return; /* * * * * * * * * * ABORT * * * * * * * * */ abort: entry (P_IB_ptr); call reset_xrsq; return; /* * * * * * * * * * MAIL_IT * * * * * * * * * */ mail_it: procedure (Which, Argument, Code); dcl Which char (4) aligned parameter; dcl Argument varying char (*); dcl Code fixed bin (35) parameter; on record_quota_overflow goto rqo_error; if (Which = "XSEN") | (Which = "XSEM") | (Which = "XMAS") then do; mail_format.wakeup = "1"b; call ftp_mail_mailer_ (Argument, mail_format_ptr, Code); if ((Which = "XSEM") & (code = 0)) | (Which = "XSEN") then return; end; mail_format.wakeup = "0"b; call ftp_mail_mailer_ (Argument, mail_format_ptr, Code); return; rqo_error: Code = error_table_$rqover; end mail_it; /* * * * * * * * * * REPLY * * * * * * * * * */ reply: procedure (Which, Code); dcl Which char (4) aligned parameter; dcl Code fixed bin (35) parameter; if Code ^= 0 then call error (450, Code, "Sending mail"); else if Which = "MLFL" then call ioa_$ioa_switch (ftp_data.iocb_ptr, "252 Mail transfer complete."); else call ioa_$ioa_switch (ftp_data.iocb_ptr, "256 Mail complete."); end reply; /* * * * * * * * * RESET_XRSQ * * * * * * * * * */ reset_xrsq: procedure; if ftp_data.mail_info.i = 2 then if ftp_data.mail_info.segptrb ^= null () then call release_temp_segment_ ("ftp_mail_", ftp_data.mail_info.segptrb, code); ftp_data.mail_info.n_users = 0; ftp_data.mail_info.segptrb = null (); end reset_xrsq; /* * * * * * * * * * ERROR * * * * * * * * * */ error: procedure (Reply, Code, Message); dcl Reply fixed bin parameter; dcl Code fixed bin (35) parameter; dcl Message char (*) parameter; dcl code_message char (100) aligned; if anonymous then call net_log_$net_error_log (0, Code, "ftp_mail_", "^a From ^a to ^a.", Message, host_name, Argument); if Reply > 0 then do; if Code = 0 then code_message = ""; else call convert_status_code_ (Code, (""), code_message); call ioa_$ioa_switch (ftp_data.iocb_ptr, "^d ^a ^a", Reply, code_message, Message); end; goto close_all_boxes; end error; /* * * * * * * * * * * * * * * * * * * */ %include ftp_server_data; %include mail_format; %include line_types; %include terminal_info; end ftp_mail_; /* ftp_mail_ */  ftp_mail_info_.alm 09/23/77 1031.6rew 09/22/77 1725.3 9684 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " A Pogran Program, 12/9/76 " " This module contains constants for use by the ftp_mail_ program, " Specifying the locations of the "Mailbox link directory", the " Network Server's home directory, and the Network Server's access name. " " This module must be changed and reassembled whenever any of these " items changes. name ftp_mail_info_ segdef mailbox_link_directory segdef mailer_directory segdef mailer_process_group_id mailbox_link_directory: aci ">udd>CNet>mailboxes",168 mailer_directory: aci ">udd>CNet>Network_Server",168 mailer_process_group_id: aci "Network_Server.*.*",32 end  ftp_read_ascii_.pl1 09/23/77 1031.6rew 09/22/77 1725.6 68571 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ ftp_read_ascii_: proc (file_ptr, file_offset, sock_index, wait_chn, amount_read, transfer_mode, code); dcl sock_state fixed bin (6); dcl (transfer_mode, header_code) fixed bin, (file_offset, amount_read, amount_converted, this_length, bytes_read, file_pos, this_block_count, area_remaining) fixed bin (24), code fixed bin (35), sock_index bit (36), wait_chn fixed binary (71), current_pos fixed bin (24) initial (0), end_of_mess fixed bin (24) initial (0); dcl (bits_read, bits_to_read) fixed bin (24); dcl (end_of_file_flag, data_not_marker) bit (1) aligned, eof_reached bit (1) aligned initial ("0"b), cr_flag bit(1) initial("0"b), heading_decoded bit (1) aligned initial ("0"b); dcl file_ptr ptr; dcl (addr, divide, length, substr, unspec) builtin; dcl 1 wait_list aligned automatic, 2 count fixed binary (17) initial (1), 2 channel fixed binary (71) initial (wait_chn); dcl not_used (4) fixed bin (71), big_buffer bit (14400) aligned; dcl (error_table_$net_invalid_state, error_table_$net_socket_closed, error_table_$area_too_small) external fixed bin (35); dcl ncp_$read_data entry (bit (36), ptr, fixed bin (24), fixed bin (24), fixed bin (6), fixed bin (35)), ipc_$block entry (ptr, ptr, fixed bin (35)), net_ascii_to_nine_ entry (bit(1), ptr, fixed bin (24), fixed bin (24), ptr, fixed bin (24), fixed bin (24)); bits_to_read = 9437184 - file_offset; go to join; read_with_count: entry (file_ptr, file_offset, amount_to_read, sock_index, wait_chn, amount_read, transfer_mode, code); dcl amount_to_read fixed bin (24); bits_to_read = amount_to_read; join: amount_read, bits_read, code = 0; file_pos = file_offset; read_it: area_remaining = divide (length (big_buffer) - end_of_mess, 8, 24, 0); call ncp_$read_data (sock_index, addr (substr (big_buffer, end_of_mess + 1, 1)), area_remaining, bytes_read, sock_state, code); if code ^= 0 then if code ^= error_table_$area_too_small | bytes_read = 0 then do; if code = error_table_$net_invalid_state | code = error_table_$net_socket_closed then if sock_state = 1 then code = 0; return; end; if bytes_read = 0 then do; call ipc_$block (addr (wait_list), addr (not_used (1)), code); if code ^= 0 then return; goto read_it; end; end_of_mess = end_of_mess + 8 * bytes_read; goto decode_type (transfer_mode); decode_type (2): /* DECODE TEXT TRANSFER MODE */ if substr (big_buffer, end_of_mess - 7, 8) = "11000001"b /* CHECK FOR EOF */ then do; eof_reached = "1"b; end_of_mess = end_of_mess - 8; if end_of_mess = 0 then return; end; decode_type (1): /* DECODE STREAM TRANSFER MODE */ call net_ascii_to_nine_ (cr_flag, addr (big_buffer), 0, end_of_mess, file_ptr, file_pos, amount_converted); bits_read = bits_read + end_of_mess; amount_read = amount_read + amount_converted; file_pos = file_pos + amount_converted; if eof_reached | bits_read >= bits_to_read then return; end_of_mess = 0; goto read_it; decode_type (3): /* DECODE BLOCK TRANSFER MODE */ if heading_decoded then goto pull_data; this_length = end_of_mess - current_pos; if this_length < 24 then do; /* HAVENT GOT THE WHOLE HEADER YET */ if current_pos ^= 0 then do; substr (big_buffer, 1, 24) = substr (big_buffer, current_pos + 1, 24); current_pos = 0; end_of_mess = this_length; end; goto read_it; end; else do; /* DECODE THIS HEADER */ unspec (header_code) = "0000000000000000000000000000"b || substr (big_buffer, current_pos + 1, 8); goto handle_header (header_code); end; handle_header (0): /* ORDINARY DATA */ handle_header (3): /* SUSPECTED BUGGY DATA */ end_of_file_flag = "0"b; data_not_marker = "1"b; goto get_count; handle_header (4): /* RESTART MARKER */ /* These are currently discarded, but may be used in the future */ end_of_file_flag = "0"b; data_not_marker = "0"b; get_count: /* get the count field from the header */ unspec (this_block_count) = "00000000000000000000"b || substr (big_buffer, current_pos + 9, 16); this_block_count = this_block_count * 8; current_pos = current_pos + 24; heading_decoded = "1"b; goto pull_data; handle_header (1): /* END OF RECORD */ /* SHOULD NEVER GET THIS, IF WE DO ERROR */ code = 1; return; handle_header (2): /* END OF FILE */ data_not_marker = "1"b; end_of_file_flag = "1"b; goto get_count; pull_data: this_length = end_of_mess - current_pos; if this_length >= this_block_count then do; if this_length = 0 then if end_of_file_flag then return; if data_not_marker then do; call net_ascii_to_nine_ (cr_flag, addr (big_buffer), current_pos, this_block_count, file_ptr, file_pos, amount_converted); bits_read = bits_read + this_block_count; amount_read = amount_read + amount_converted; file_pos = file_pos + amount_converted; end; if end_of_file_flag | bits_read >= bits_to_read then return; heading_decoded = "0"b; current_pos = current_pos + this_block_count; if current_pos = end_of_mess then do; current_pos, end_of_mess = 0; goto read_it; end; goto decode_type (3); end; else do; if data_not_marker then do; call net_ascii_to_nine_ (cr_flag, addr (big_buffer), current_pos, this_length, file_ptr, file_pos, amount_converted); amount_read = amount_read + amount_converted; file_pos = file_pos + amount_converted; end; current_pos, end_of_mess = 0; this_block_count = this_block_count - this_length; goto read_it; end; end;  ftp_read_image_.pl1 09/23/77 1031.6rew 09/22/77 1725.3 50769 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ ftp_read_image_: proc (file_ptr, file_offset, sock_index, wait_chn, amount_read, transfer_mode, bytesize, code); dcl (file_offset, amount_read) fixed bin (24), transfer_mode fixed bin, bytesize fixed bin (8), code fixed bin (35), sock_index bit (36); dcl wait_chn fixed binary (71); dcl (read_pos, bytes_read, bits_read, bits_to_read, current_pos, last_pos_used) fixed bin (24), sock_state fixed bin (6), (header_code, this_block_count, blocklet, pad) fixed bin; dcl file_ptr ptr, (end_of_file_flag, data_not_marker) bit (1) aligned, (addr, mod, max, min, substr, unspec, divide) builtin; dcl 1 wait_list aligned automatic, 2 count fixed binary (17) initial (1), 2 channel fixed binary (71) initial (wait_chn); dcl not_used (4) fixed bin (71), long_string bit (1000) aligned based, (error_table_$net_invalid_state, error_table_$net_socket_closed) external fixed bin (35), ipc_$block entry (ptr, ptr, fixed bin (35)), ncp_$read_data entry (bit (36), ptr, fixed bin (24), fixed bin (24), fixed bin (6), fixed bin (35)); read: proc; read_it: call ncp_$read_data (sock_index, addr (substr (file_ptr -> long_string, read_pos + 1, 1)), divide (bits_to_read - amount_read, bytesize, 24, 0), bytes_read, sock_state, code); bits_read = bytes_read * bytesize; amount_read = amount_read + bits_read; read_pos = read_pos + bits_read; if amount_read >= bits_to_read then return; if code ^= 0 then do; if code = error_table_$net_invalid_state | code = error_table_$net_socket_closed then code = 0; /* check for his close */ goto ext_return; end; if bytes_read = 0 then do; call ipc_$block (addr (wait_list), addr (not_used (1)), code); if code ^= 0 then goto ext_return; goto read_it; end; end; bits_to_read = 9437184 - file_offset; go to join; read_with_count: entry (file_ptr, file_offset, amount_to_read, sock_index, wait_chn, amount_read, transfer_mode, bytesize, code); dcl amount_to_read fixed bin (35); bits_to_read = amount_to_read; join: amount_read = 0; current_pos = file_offset; goto input_data (transfer_mode); ext_return: return; /* used by internal routine read */ input_data (1): /* stream transfer */ read_pos = current_pos; in1: call read; go to in1; input_data (2): /* text transfer, bytesize must be 8 */ read_pos = current_pos; in2: call read; if substr (file_ptr -> long_string, read_pos - 7, 8) = "11000001"b /* eof */ then do; substr (file_ptr -> long_string, read_pos - 7, 8) = "00000000"b; amount_read = amount_read - 8; return; end; goto in2; input_data (3): /* block transfer */ pad = bytesize - (mod (23, bytesize) + 1); /* to do stupid right adjusting */ read_pos = current_pos; last_pos_used = current_pos; in3: call read; last_pos_used = max (read_pos, last_pos_used); in3a: if read_pos - current_pos < 24 then goto in3 /* havent got whole header yet */; unspec (header_code) = "0000000000000000000000000000"b || substr (file_ptr -> long_string, current_pos + pad + 1, 8); goto handle_header (header_code); handle_header (0): /* ordinary data */ handle_header (3): /* suspected buggy data */ end_of_file_flag = "0"b; data_not_marker = "1"b; goto get_count; handle_header (4): /* restart marker */ data_not_marker = "0"b; end_of_file_flag = "0"b; goto get_count; handle_header (2): /* end of file */ data_not_marker = "1"b; end_of_file_flag = "1"b; goto get_count; handle_header (1): /* end of record */ code = 1; /* should never get this */ return; /* if we do error */ get_count: unspec (this_block_count) = "00000000000000000000"b || substr (file_ptr -> long_string, current_pos + pad + 9, 16); this_block_count = this_block_count * bytesize; current_pos = current_pos + 24 + pad; bits_read = bits_read - 24 - pad; /* following code to shuffle data around in the segment */ shuffle_data: blocklet = min (bits_read, this_block_count); this_block_count = this_block_count - blocklet; if data_not_marker then do; if blocklet ^= 0 then if file_offset + amount_read < current_pos then substr (file_ptr -> long_string, file_offset + amount_read + 1, blocklet) = substr (file_ptr -> long_string, current_pos + 1, blocklet); amount_read = amount_read + blocklet; end; current_pos = current_pos + blocklet; if this_block_count ^= 0 then do; /* this block not yet complete */ current_pos, read_pos = file_offset + amount_read; call read; last_pos_used = max (read_pos, last_pos_used); goto shuffle_data; end; else do; /* ready to do next block */ if ^ end_of_file_flag then do; if current_pos < read_pos then goto in3a; current_pos, read_pos = file_offset + amount_read; goto in3; end; else do; /* finish up the eof block */ last_pos_used = last_pos_used - (file_offset + amount_read); if last_pos_used > 0 then substr (file_ptr -> long_string, file_offset + amount_read + 1, last_pos_used) = ""b; /* blank the rest of the junk in file */ return; end; end; end;  ftp_server_listen_.pl1 09/23/77 1031.6rew 09/22/77 1725.1 47439 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ ftp_server_listen_: procedure (P_IB_ptr); /* A Pogran Program 01/16/73 This module acts as the listener for a File Transfer server process. It also includes the "QUIT", or "ABORT" handler. It is called by ftp_server_overseer_ after the File Transfer default handler has been established. This module also implements the ftp_server command, which transforms a user's process into an ftp server process. The standard default handler remains in effect. The ftp_server_test command is the same as the ftp_server command, except that the standard QUIT handler remais in effect, and the user is not required to be logged in via the Network. Last modified by Ken Pogran 02/20/73 Last modified by D. M. Wells in June 1976, to allow "ftpxxx" form of control channel names, enable quits via the input stream. Last modified by D. M. Wells to use line type to determine net channels. */ declare P_IB_ptr ptr; %include ftp_server_data; declare 1 ftp_data aligned like ftp_data_template; declare quit_flag bit (1), command_line char (256), nelemt fixed bin(21), code fixed bin (35); declare 1 tty_info automatic aligned, 2 id char (4) unaligned, 2 baud_rate fixed bin (17) unaligned, 2 line_type fixed bin (17) unaligned, 2 reserved bit (36) unaligned, 2 term_type fixed bin (17); declare ioa_$ioa_switch entry options (variable), com_err_ entry options (variable), condition_ entry (char (*), entry), iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), ftp_command_processor_ entry (ptr, char (*), bit (1)), ftp_initialization_$cleanup entry (ptr, bit (1)), ftp_server_overseer_$ftp_logout entry (ptr, bit (1)); declare iox_$user_io external pointer; declare error_table_$badcall external fixed bin (35); declare (addr, length, null, substr) builtin; % include line_types; set_abort_label: P_IB_ptr -> ftp_data_template.abort_return_label = set_abort_label; quit_flag = ""b; call condition_ (P_IB_ptr -> ftp_data_template.quit_condition, ftp_quit); if P_IB_ptr -> ftp_data_template.quit_condition = "quit" then call iox_$control (iox_$user_io, "quit_enable", null (), code); call read_command_line (); return; bye: entry (P_IB_ptr, hold); /* This entry implements the "BYE" and "REIN" commands. */ declare hold bit (1); /* Tells if logout hold ("REIN") wanted */ if ^ P_IB_ptr -> ftp_data_template.ftp_server_process then do; if hold /* "REIN" asked for */ then do; call ioa_$ioa_switch (P_IB_ptr -> ftp_data_template.iocb_ptr, "504 TELNET users should use BYE rather than REIN."); return; end; call ftp_initialization_$cleanup (P_IB_ptr, "0"b); go to P_IB_ptr -> ftp_data_template.static_return_label; end; call ftp_server_overseer_$ftp_logout (P_IB_ptr, hold); read_command_line: procedure (); do while ("1"b); call iox_$get_line (P_IB_ptr -> ftp_data_template.iocb_ptr, addr (command_line), length (command_line), nelemt, code); if code ^= 0 then return; if nelemt > 1 then do; call ftp_command_processor_ (P_IB_ptr, substr (command_line, 1, nelemt - 1), quit_flag); if quit_flag then return; end; end; return; end read_command_line; ftp_quit: procedure(); call ioa_$ioa_switch (P_IB_ptr -> ftp_data_template.iocb_ptr, "020 SYNC received. Enter command."); P_IB_ptr -> ftp_data_template.rename_in_progress = "0"b; quit_flag = "1"b; call condition_ (P_IB_ptr -> ftp_data_template.quit_condition, ftp_double_quit); call read_command_line (); return; end ftp_quit; ftp_double_quit: procedure (); /* Got another QUIT before we did anything about the first one */ call ioa_$ioa_switch (P_IB_ptr -> ftp_data_template.iocb_ptr, "021 SYNC ignored."); return; end ftp_double_quit; end ftp_server_listen_;  ftp_server_overseer_.pl1 09/23/77 1031.6rew 09/22/77 1725.6 81711 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ ftp_server_overseer_: procedure; /* A Pogran Program 01/16/73 This module is the process overseer for a user's file transfer server process. It is the first in a chain of modules which restrict a user to performing only file transfer functions in his process. All unexpected errors (conditions) are considered fatal. Also included in this module are the following: 1) The default handler for conditions occuring during file transfer, 2) The entry to "log out" a file transfer process. Modified by Ken Pogran to call condition_ and add handlers for cput and alrm, 09/24/74. Modified 2/14/75 (Happy Valentine's Day!) by Ken Pogran to: 1. Add no_handler entry point for debugging 2. Change call to cpu_time_and_paging_ to hcs_$get_process_usage so that memory usage may be printed upon logout. Last modified by Ken Pogran 02/18/75 Last modified by D. M. Wells to not count on AS saying "hangup", to not deactivate socket, and to not setup timer handlers. Last modified by S. T. Kent to use iox and to consolidate internal-external static. */ declare 1 logout_info internal static options (constant) aligned, 2 version fixed bin initial (0), 2 hold bit (1) initial ("0"b) unaligned, 2 brief bit (1) initial ("1"b) unaligned, /* He will _n_o_t get standard logout message! */ 2 pad bit (34) unaligned initial (""b); declare condition_ entry (char (*), entry), ioa_$ioa_switch entry options (variable), terminate_process_ entry (char (*), ptr), condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr), ftp_initialization_$init_ftp_data entry (ptr), ftp_server_listen_ entry (ptr); %include ftp_server_data; declare iox_$user_io external ptr; declare 1 ftp_data aligned like ftp_data_template; declare first_time bit (1) initial ("1"b); declare (addr, divide, empty, float, length, mod, null) builtin; call condition_ ("any_other", ftp_default_handler_); no_handler: entry; /* Come in without special handler, for debugging purposes. /*/ call ftp_initialization_$init_ftp_data (addr (ftp_data)); call initialize_process (); ftp_data.ftp_server_process = "1"b; ftp_data.iocb_ptr = iox_$user_io; ftp_data.static_return_label = flush_ftp_process; call ftp_server_listen_ (addr(ftp_data)); /* The listener never returns (it says here . . .) */ flush_ftp_process: call logout_process (addr (ftp_data)); return; ftp_server: entry (); call initialize_server (); ftp_data.ftp_server_process = "0"b; call ftp_server_listen_ (addr (ftp_data)); return; ftp_server_test: entry (); call initialize_server (); ftp_data.ftp_server_process = "0"b; ftp_data.quit_condition = "program_interrupt"; call ftp_server_listen_ (addr (ftp_data)); return; ftp_logout: entry (P_IB_ptr, logout_hold); /* This entry implements the "BYE" and "REIN" commands */ declare P_IB_ptr pointer; /* Note: We currently ignore the fact that REIN rather than BYE was requested. This will remain true until the Answering Service handles FTP dialups properly, rather than in the present limited manner. */ declare logout_hold bit (1); /* If "1"b, indicates he typed REIN rather than BYE */ call logout_process (P_IB_ptr); return; leave_server_environment: call ioa_$ioa_switch (ftp_data.iocb_ptr, "231 Leaving File Transfer server environment."); return; initialize_process: procedure; declare code fixed bin (35), error condition, date_and_time char (24), name char (22) internal static, project char (9) internal static, login_time fixed bin (71), cpu_secs fixed bin, home_dir char (168), old_modes char (200); declare 1 process_statistics aligned, 2 num_items fixed bin initial (5), 2 num_returned fixed bin, 2 total_cpu fixed bin (71), 2 memory_usage fixed bin (71), 2 page_faults fixed bin (35), 2 bs_page_faults fixed bin (35), 2 virtual_cpu fixed bin (71); declare clock_ entry returns (fixed bin (71)), change_wdir_ entry (char (168), fixed bin (35)), date_time_ entry (fixed bin (71), char (*)), hcs_$get_process_usage entry (ptr, fixed bin (35)), user_info_$homedir entry (char (*)), user_info_$login_data entry (char (*), char (*), char (*), fixed bin, fixed bin, fixed bin, fixed bin (71), char (*)), iox_$modes entry (ptr, char (*), char (*), fixed bin(35)) ; call user_info_$login_data (name, project, "", 0, 0, 0, login_time, ""); call date_time_ (login_time, date_and_time); ftp_data.iocb_ptr = iox_$user_io; call ioa_$ioa_switch (ftp_data.iocb_ptr, "230 ^a ^a logged in for file transfer: ^a", name, project, date_and_time); call iox_$modes (ftp_data.iocb_ptr, "^erkl", old_modes, code); call user_info_$homedir (home_dir); call change_wdir_ (home_dir, code); return; logout_process: entry(P_IB_ptr); /* This entry implements the file transfer "BYE" command. */ declare P_IB_ptr pointer; call hcs_$get_process_usage (addr (process_statistics), code); cpu_secs = divide (virtual_cpu, 1000000, 17, 0); call date_time_ (clock_(), date_and_time); if cpu_secs > 60 then call ioa_$ioa_switch (ftp_data.iocb_ptr, "231- ^a ^a logged out ^a 231 CPU usage ^d min ^d sec, memory usage ^.1f units.", name, project, date_and_time, divide (cpu_secs, 60, 17, 0), mod (cpu_secs, 60), float (memory_usage)/1000); else call ioa_$ioa_switch (ftp_data.iocb_ptr, "231- ^a ^a logged out ^a^/231 CPU usage ^d sec, memory usage ^.1f units.", name, project, date_and_time, cpu_secs, float (memory_usage)/1000); call terminate_process_ ("logout", addr (logout_info)); /* Goodbye! */ on error; end initialize_process; initialize_server: procedure (); call ftp_initialization_$init_ftp_data (addr (ftp_data)); ftp_data.iocb_ptr = iox_$user_io; ftp_data.static_return_label = leave_server_environment; call ioa_$ioa_switch (ftp_data.iocb_ptr, "230 File Transfer server environment established."); return; end initialize_server; ftp_default_handler_: procedure (mcptr, cond_name, wcptr, infoptr, continue); declare mcptr ptr, wcptr ptr, infoptr ptr, cond_name char (*), continue bit (1); declare code fixed bin(35), message_length fixed bin, message_string char(message_length) based (message_ptr), message_area area (250), message_ptr pointer; if cond_name = "finish" then return; if first_time then do; first_time = "0"b; call condition_interpreter_ (addr (message_area), message_ptr, message_length, 1, mcptr, cond_name, wcptr, infoptr); call ioa_$ioa_switch (ftp_data.iocb_ptr, "435- Unexpected error encountered:"); call ioa_$ioa_switch (ftp_data.iocb_ptr, "^a", substr (message_string, 9)); call ioa_$ioa_switch (ftp_data.iocb_ptr, "435 File transfer process terminated."); end; call terminate_process_ ("logout", addr (logout_info)); /* Goodbye! */ end ftp_default_handler_; end ftp_server_overseer_;  ftp_server_status_.pl1 09/23/77 1031.6rew 09/22/77 1725.3 130068 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ ftp_server_status_: procedure (P_IB_ptr, argument); declare argument char (*) varying, P_IB_ptr ptr; declare 1 ftp_data aligned like ftp_data_template defined (P_IB_ptr -> ftp_data_template); /* A Pogran Program 02/13/73 This module implements the "STAT", "NLST" and "LIST" commands of the File Transfer Protocol. A STAT command with no arguments, or with an argument which begins with a hyphen, is taken to be a "system" or "user" or "ftp" status request. A STAT command with a pathname argument is taken to be either a directory listing request, if the branch specified is a directory, or a segment status request if the branch is a segment. The "LIST" command (implemented by the entry ftp_server_status_$list) eventually will return the file-system status information given by STAT over the FTP data socket, rather than the Telnet socket. But that comes later. The "NLST" command (implemented by ftp_server_status_$namelist) returns a list of the names of all segments contained in a directory, over the FTP data socket. Modified by K. T. Pogran 02/26/73 Modfied to add NLST and upgrade to new condition info structure by Ken Pogran, 3/3/75 Last modified by Ken Pogran, 3/4/75 Last modified by D. M. Wells to get rid of all 455 reply codes. */ declare pathname char (168), dirname char (168), ename char (32), code fixed bin (35), type fixed bin (2), bitcnt fixed bin (24), short_message char (8) aligned, error_message char (100) aligned, reply_code char (3); declare name char (32), project char (12), account char (4), anon fixed bin (1), standby fixed bin (1), weight fixed bin, login_time fixed bin (71), login_word char (8), idcode char (4), tty_type fixed bin, channel char (6), host_number fixed bin (16), host_name char (32) initial (""), host_string char (40) varying, date_time char (24), page_faults fixed bin, cpu_time fixed bin (71), pre_pages fixed bin, cpu_secs fixed bin, cpu_min fixed bin, cpu_usage char (16), len fixed bin (24); declare entry_count fixed bin, eptr pointer, nptr pointer, text_pos fixed bin (24), i fixed bin; declare text char (text_pos) based (ftp_data.text_ptr); declare 1 entries (entry_count) aligned based (eptr), (2 type bit (2), 2 nnames bit (16), 2 nindex bit (18)) unaligned; declare names (100) char (32) aligned based (nptr); %include ftp_server_data; declare Directory fixed bin (2) initial (2); declare expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), absolute_pathname_ entry (char (*), char (*), fixed bin (35)), hcs_$status_minf entry (char (*), char (*), fixed bin, fixed bin (2), fixed bin (24), fixed bin (35)), user_info_$login_data entry (char (*), char (*), char (*), fixed bin (1), fixed bin (1), fixed bin, fixed bin (71), char (*)), user_info_$tty_data entry (char (*), fixed bin, char (*)), host_id_$number entry (fixed bin (16), char (*), fixed bin (35)), host_id_$symbol entry (fixed bin (16), char (*), fixed bin (35)), date_time_ entry (fixed bin (71), char (*)), clock_ entry returns (fixed bin (71)), cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin), ioa_$rsnnl entry options (variable), get_wdir_ entry returns (char (168)), ioa_$ioa_switch entry options (variable), condition_ entry (char (*), entry), list entry (char (*), char (*), char (*)), status entry (char (*)), convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); declare get_system_free_area_ entry returns (pointer), hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), check_star_name_$path entry (char (*), fixed bin (35)), ftp_initialization_$socket_init entry (ptr, fixed bin (35)), file_transfer_$list_transfer entry (ptr, ptr, fixed bin(24)); declare (error_table_$moderr, error_table_$incorrect_access, error_table_$no_dir, error_table_$noentry) fixed bin (35) external; declare (length, substr, index, divide, fixed, verify, reverse, null) builtin; if ftp_data.foreign_host = -1 then call ftp_initialization_$socket_init (addr (ftp_data), (0)); if substr (argument, 1, 1) = "-" | length (argument) = 0 /* Does he want "system" status or "file" status? */ then do; call user_info_$login_data (name, project, account, anon, standby, weight, login_time, login_word); call user_info_$tty_data (idcode, tty_type, channel); call host_id_$number (host_number, idcode, code); if code = 0 then do; call host_id_$symbol (host_number, host_name, code); if code ^= 0 then host_name = ""; end; if host_name ^= "" then host_string = "from " || host_name; else host_string = ""; call date_time_ (login_time, date_time); call ioa_$ioa_switch (ftp_data.iocb_ptr, "100- ^a ^a logged in at ^a ^a", name, project, date_time, host_string); call date_time_ (clock_ (), date_time); call cpu_time_and_paging_ (page_faults, cpu_time, pre_pages); cpu_secs = divide (cpu_time + 500000, 1000000, 17, 0); if cpu_secs > 60 then do; cpu_min = divide (cpu_secs, 60, 17, 0); cpu_secs = cpu_secs - cpu_min * 60; call ioa_$rsnnl ("^d min ^d sec", cpu_usage, len, cpu_min, cpu_secs); end; else call ioa_$rsnnl ("^d sec", cpu_usage, len, cpu_secs); call ioa_$ioa_switch (ftp_data.iocb_ptr, "^5xCPU usage ^a at ^a^/^5xWorking directory is ^a", cpu_usage, substr (date_time, 11, 6), get_wdir_ ()); call ioa_$ioa_switch (ftp_data.iocb_ptr, "^5xData socket is ^d at ^a", ftp_data.foreign_read_socket, ftp_data.foreign_host_name); call ioa_$ioa_switch (ftp_data.iocb_ptr, "100 Files will be transferred in ^a ^d-bit ^a.", mode_name (ftp_data.transfer_mode), ftp_data.byte_size, type_name (ftp_data.representation_type)); end; else do; pathname = argument; call expand_pathname_ (pathname, dirname, ename, code); if code ^= 0 then go to bad_path; call hcs_$status_minf (dirname, ename, 0, type, bitcnt, code); if code ^= 0 then go to error_reply; call condition_ ("command_error", status_error); if type = Directory then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "151- Listing of ^a>^a:", dirname, ename); call list ("-pathname", pathname, "-all"); call ioa_$ioa_switch (ftp_data.iocb_ptr, "151 Directory listing complete."); end; else do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "150- Status of ^a>^a:", dirname, ename); call status (pathname); call ioa_$ioa_switch (ftp_data.iocb_ptr, "150 Status complete."); end; end; return; bad_path: call convert_status_code_ (code, short_message, error_message); call ioa_$ioa_switch (ftp_data.iocb_ptr, "550 ^a ^a", error_message, pathname); return; error_reply: if code = error_table_$moderr | code = error_table_$incorrect_access then reply_code = "451"; else if code = error_table_$noentry | code = error_table_$no_dir then reply_code = "450"; else reply_code = "451"; call convert_status_code_ (code, short_message, error_message); call ioa_$ioa_switch (ftp_data.iocb_ptr, "^a ^a ^a>^a", reply_code, error_message, dirname, ename); return; list: entry (P_IB_ptr, argument); call ioa_$ioa_switch (ftp_data.iocb_ptr, "506 LIST is not implemented at this time; use STAT or NLST."); return; namelist: entry (P_IB_ptr, argument); pathname = argument; call check_star_name_$path (pathname, code); if code = 0 then do; ename = "**"; call absolute_pathname_ (pathname, dirname, code); end; else if code = 1 | code = 2 then call expand_pathname_ (pathname, dirname, ename, code); if code ^= 0 then go to bad_path; call hcs_$star_ (dirname, ename, 2 /* no info about links */, get_system_free_area_ (), entry_count, eptr, nptr, code); if code ^= 0 then go to bad_path; if ftp_data.text_ptr = null then do; call hcs_$make_seg ("", "namelist_temp", "", 1010b, ftp_data.text_ptr, code); if code ^= 0 then do; call ioa_$ioa_switch (ftp_data.iocb_ptr, "453 Cannot create required workspace; Multics FTP Server error."); return; end; end; text_pos = 0; do i = 1 to entry_count; if entries(i).type = "01"b /* Non-directory segment -- we DON'T handle MSF's yet! */ then do; substr (text, text_pos + 1, 32) = names (fixed (entries(i).nindex, 17)); text_pos = text_pos + 33 - verify (reverse (substr (text, text_pos + 1, 32)), " "); substr (text, text_pos + 1, 1) = " "; text_pos = text_pos + 1; end; end; if text_pos = 0 then if ename = "**" then call ioa_$ioa_switch (ftp_data.iocb_ptr, "450 There are no segments in ^a.", dirname); else call ioa_$ioa_switch (ftp_data.iocb_ptr, "450 There are no segments in ^a which match the star name ^a.", dirname, ename); else call file_transfer_$list_transfer (addr (ftp_data), ftp_data.text_ptr, text_pos); return; status_error: procedure (mc_ptr, cond_name, wc_ptr, info_ptr, continue); declare mc_ptr pointer, cond_name char (*), wc_ptr pointer, info_ptr pointer, continue bit (1); declare 1 info_struc aligned based (info_ptr), 2 info_length fixed bin, 2 version fixed bin, 2 action_flags bit (36), 2 info_string char (256) varying, 2 status_code fixed bin (35), 2 name_ptr pointer, 2 name_lth fixed bin, 2 errmess_ptr pointer, 2 errmess_lth fixed bin, 2 max_err_lth fixed bin, 2 print_sw bit (1); declare errmess char (max_err_lth) based (errmess_ptr); declare message char (256) varying, pos fixed bin; continue = "0"b; print_sw = "1"b; pos = index (errmess, ": "); if pos = 0 then pos = 1; else pos = pos + 2; message = substr (errmess, pos, errmess_lth - pos); if status_code = 0 then if message = "** not found." /* Lousy system message */ then message = "Directory is empty."; /* Nice message */ errmess_lth = length (message) + 6; substr (errmess, 1, errmess_lth) = " " || message || " "; end status_error; end ftp_server_status_;  ftp_write_ascii_.pl1 09/23/77 1031.6rew 09/22/77 1725.1 38124 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ ftp_write_ascii_: proc (file_ptr, file_offset, file_count, sock_index, wait_chn, transfer_mode, code); dcl sock_state fixed bin (6), transfer_mode fixed bin, (file_offset, file_count, remaining_file_count, this_length, converted_length, current_file_offset, current_pos, end_of_data, bytes_written) fixed bin (24), code fixed bin (35); dcl wait_chn fixed binary (71); dcl sock_index bit (36); dcl file_ptr ptr; dcl done_flag bit (1) aligned initial ("0"b); dcl (addr, length, substr, divide, unspec) builtin; dcl 1 wait_list aligned automatic, 2 count fixed binary (17) initial (1), 2 channel fixed binary (71) initial (wait_chn); dcl not_used (4) fixed bin (71), big_buffer bit (32048) aligned; dcl net_ascii_to_eight_ entry (ptr, fixed bin (24), fixed bin (24), ptr, fixed bin (24), fixed bin (24)), ncp_$write_data entry (bit (36), ptr, fixed bin (24), fixed bin (24), fixed bin (6), fixed bin (35)), ipc_$block entry (ptr, ptr, fixed bin (35)), ncp_$close_connection entry (bit (36), fixed bin (6), fixed bin (35)); current_file_offset = file_offset; remaining_file_count = file_count; send_loop: if remaining_file_count > 9 * divide (length (big_buffer) - 24, 16, 24, 0) then this_length = 9 * divide (length (big_buffer) - 24, 16, 24, 0); else do; this_length = remaining_file_count; done_flag = "1"b; end; call net_ascii_to_eight_ (file_ptr, current_file_offset, this_length, addr (big_buffer), 24, converted_length); current_file_offset = current_file_offset + this_length; remaining_file_count = remaining_file_count - this_length; goto setup_for_sending (transfer_mode); setup_for_sending (2): /* SETUP FOR TEXT TRANSFER MODE */ /* IF EOF THEN PUT IN EOF MARKER */ current_pos = 24; end_of_data = 24 + converted_length; if done_flag then do; substr (big_buffer, end_of_data + 1, 8) = "11000001"b; /* EOF MARKER */ end_of_data = end_of_data + 8; end; goto write_loop; setup_for_sending (1): /* SETUP FOR STREAM TRANSFER MODE */ current_pos = 24; end_of_data = 24 + converted_length; goto write_loop; setup_for_sending (3): /* SETUP BLOCK TRANSFER MODE */ current_pos = 0; end_of_data = 24 + converted_length; converted_length = divide (converted_length, 8, 24, 0); substr (big_buffer, 1, 24) = "00000000"b /* MARKER FOR DATA */ || substr (unspec (converted_length), 21, 16); if done_flag then substr (big_buffer, 1, 8) = "00000010"b /* eof marker */; write_loop: do while (current_pos < end_of_data); call ncp_$write_data (sock_index, addr (substr (big_buffer, current_pos + 1, 1)), divide (end_of_data - current_pos, 8, 24, 0), bytes_written, sock_state, code); if code ^= 0 then return; current_pos = current_pos + 8 * bytes_written; if bytes_written = 0 then do; call ipc_$block (addr (wait_list), addr (not_used (1)), code); if code ^= 0 then return; end; end; if ^ done_flag then goto send_loop; if transfer_mode = 1 /* MUST CLOSE SOCKET TO INDICATE EOF */ then do; call ncp_$close_connection (sock_index, sock_state, code); if code ^= 0 then return; end; return; end;  ftp_write_image_.pl1 09/23/77 1031.6rew 09/22/77 1725.6 38601 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ ftp_write_image_: proc (file_ptr, file_offset, file_count, sock_index, wait_chn, transfer_mode, his_bytesize, code); dcl sock_state fixed bin (6), (bytesize, his_bytesize) fixed bin (8), transfer_mode fixed bin (17), (file_offset, file_count, out_pos, out_end, current_out_pos, bytes_written, byte_count, pad) fixed bin (24), code fixed bin (35); dcl sock_index bit (36); dcl (file_ptr, out_ptr) ptr, wait_chn fixed binary (71), (divide, addr, mod) builtin; dcl 1 wait_list aligned automatic, 2 count fixed binary (17) initial (1), 2 channel fixed binary (71) initial (wait_chn); dcl ncp_$close_connection entry (bit (36), fixed bin (6), fixed bin (35)), not_used (4) fixed bin (71), ncp_$write_data entry (bit (36), ptr, fixed bin (24), fixed bin (24), fixed bin (6), fixed bin (35)), ipc_$block entry (ptr, ptr, fixed bin (35)), long_overlay bit (1000) aligned based, internal_buffer bit (256) aligned; bytesize = his_bytesize; goto setup (transfer_mode); error_return: return; /* for use by internal procs */ setup (3): /* setup for block transfer */ internal_buffer = ""b; /* zero buffer */ byte_count = divide (file_count + bytesize - 1, bytesize, 24, 0); pad = bytesize - (mod (23, bytesize) + 1); /* to do the stupid right adjusting */ substr (internal_buffer, pad + 1, 24) = "00000010"b /* eof marker */ || substr (unspec (byte_count), 21, 16); out_pos = 0; /* setup to send this header */ out_end = pad + 24; out_ptr = addr (internal_buffer); call send_data; goto send_actual_file; setup (1): /* setup for stream transfer */ setup (2): /* setup for text transfer */ /* note mode 2 only valid for bytesize = 8 */ /* no setup necessary, send file */ send_actual_file: out_pos = file_offset; out_end = file_offset + file_count; out_ptr = file_ptr; call send_data; goto finish (transfer_mode); finish (1): /* close socket for eof signal */ call ncp_$close_connection (sock_index, sock_state, code); return; finish (2): /* send code for eof then return */ substr (internal_buffer, 1, 8) = "11000001"b; /* eof marker */ out_pos = 0; out_end = 8; out_ptr = addr (internal_buffer); call send_data; return; finish (3): /* dont need to do anything more */ return; send_data: proc; current_out_pos = out_pos; do while (current_out_pos < out_end); call ncp_$write_data (sock_index, addr (substr (out_ptr -> long_overlay, current_out_pos + 1, 1)), divide (out_end + bytesize - current_out_pos - 1, bytesize, 24, 0), bytes_written, sock_state, code); if code ^= 0 then goto error_return; current_out_pos = current_out_pos + bytesize * bytes_written; if bytes_written = 0 then do; call ipc_$block (addr (wait_list), addr (not_used (1)), code); if code ^= 0 then goto error_return; end; end; end; end;  net_ascii_to_eight_.pl1 09/23/77 1031.6rew 09/22/77 1723.9 20250 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ net_ascii_to_eight_: proc (nine_ptr, nine_offset, nine_count, eight_ptr, eight_offset, eight_count); dcl (eight_count, nine_count, eight_offset, nine_offset, i, j) fixed bin (24); dcl (eight_ptr, nine_ptr, net_ptr, mult_ptr) ptr; dcl substr builtin; dcl working_bits bit (8) aligned, cr_flag bit (1) , long_string bit (1048576) aligned based; net_ptr = eight_ptr; mult_ptr = nine_ptr; j = eight_offset; do i = nine_offset + 1 to (nine_offset + nine_count) - 8 by 9; working_bits = substr (mult_ptr -> long_string, i + 1, 8); if working_bits = "00001010"b /* new line */ then do; substr (net_ptr -> long_string, j + 1, 8) = "00001101"b /* carriage return */ ; j = j + 8; end; substr (net_ptr -> long_string, j + 1, 8) = working_bits; j = j + 8; end; eight_count = j - eight_offset; return; net_ascii_to_nine_: entry (cr_flag, eight_ptr, eight_offset, eight_count, nine_ptr, nine_offset, nine_count); net_ptr = eight_ptr; mult_ptr = nine_ptr; j = nine_offset; do i = eight_offset to (eight_offset + eight_count) - 8 by 8; working_bits = substr (net_ptr -> long_string, i + 1, 8); if working_bits = "00001101"b /* carriage return */ then cr_flag = "1"b; else if cr_flag then do; cr_flag = "0"b; if working_bits = "00001010"b /* line feed */ then j = j - 9; end; substr (mult_ptr -> long_string, j + 1, 9) = "0"b || working_bits; j = j + 9; end; nine_count = j - nine_offset; end;  netml_responder_.pl1 10/28/80 1503.8rew 10/28/80 1232.5 75663 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ netml_responder_: procedure; /* A Pogran Program, 02/14/74 (Happy Valentine's Day, Judy!) This procedure implements major portions of the stripped-down File Transfer Server for the mail-receiving process, NETML.CNet. Modified by Ken Pogran to add Development Machine commands, 09/18/74 Modified to remove use of special version of ntw_, etc. by Ken Pogran, 09/23/74 Modified to put replace_ntw back in due to a bug in the installed ntw_, Ken Pogran, 09/24/74 Modified by Ken Pogran to establish handlers for cput and alrm, 09/24/74 Modified by Ken Pogran, 09/24/74 Modified by Ken Pogran, 2/21/75 to accept default TYPE, MODE, and BYTE requests, and remove call to replace_ntw. Modified by Ken Pogran 3/12/75 to incorporate auditing suggestions made by Doug Wells. Modified by D. M. Wells 08/27/76 to not deactivate sockets and to not set up timer manager handlers; timer handlers are now setup automatically; processes are not allowed to detach sockets, and it costs time. Modified by S.T. Kent 11/13/76 to permit use in a tasking environment. Modified by C. Hornig May 1980 for XRSQ etc. */ declare first_time bit (1) initial ("1"b), tasking bit (1) initial ("0"b), testing bit (1) initial ("0"b), task_iocb_ptr ptr, nelemt fixed bin (24), command_length fixed bin (24), command_line char (256), response_line char (256), response_len fixed binary (24), code fixed bin (35), argument char (128) varying, command char (4), arg_begin fixed bin; declare upper_case char (26) internal static options (constant) initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"), lower_case char (26) internal static options (constant) initial ("abcdefghijklmnopqrstuvwxyz"); declare 1 logout_info internal static options (constant) aligned, 2 version fixed bin initial (0), 2 hold bit (1) unaligned initial ("0"b), 2 brief bit (1) unaligned initial ("1"b), 2 unused bit (34) unaligned initial (""b); declare 1 editing_chars_structure aligned internal static options (constant), 2 version fixed bin initial (1), 2 editing_chars (3) bit (9) aligned initial ((3) (1)"111111111"b); declare iox_$user_io external ptr; %include ftp_server_data; declare 1 ftp_data aligned like ftp_data_template; declare condition_ entry (char (*), entry), ioa_$ioa_switch entry options (variable), ioa_$rs entry options (variable), iox_$control entry (ptr, char (*), ptr, fixed bin (35)), iox_$get_line entry (ptr, ptr, fixed bin (24), fixed bin (24), fixed bin (35)), iox_$modes entry (ptr, char (*), char (*), fixed bin (35)), iox_$put_chars entry (ptr, ptr, fixed bin (24), fixed bin (35)), net_log_ constant entry options (variable), terminate_process_ entry (char (*), ptr), ftp_initialization_$init_ftp_data entry (ptr), ftp_mail_$anonymous_mail entry (ptr, char (*), char (*) varying), ftp_mail_$abort entry (ptr); declare (addr, length, substr, index, null, verify, translate) builtin; testing = "0"b; call setup (iox_$user_io); call condition_ ("any_other", netml_default_handler); go to read_command_line; task_mode: entry (task_iocb_ptr); testing = "0"b; call setup (task_iocb_ptr); call condition_ ("any_other", netml_default_handler); tasking = "1"b; go to read_command_line; test: entry; testing = "1"b; call setup (iox_$user_io); goto read_command_line; read_command_line: call iox_$get_line (ftp_data.iocb_ptr, addr (command_line), length (command_line), nelemt, code); if code ^= 0 then return; if nelemt = 1 then go to read_command_line; command_length = index (substr (command_line, 1, nelemt - 1), " ") - 1; if command_length = -1 then command_length = nelemt - 1; command = translate (substr (command_line, 1, command_length), upper_case, lower_case); if command = "BYE" then do; call ftp_mail_$abort (addr (ftp_data)); call ioa_$ioa_switch (ftp_data.iocb_ptr, "231 Mail Server Process terminated."); if tasking | testing then return; call terminate_process_ ("logout", addr (logout_info)); end; else if command = "NOOP" then call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 NOOP command accepted."); else if command = "MAIL" | command = "MLFL" | command = "XSEN" | command = "XSEM" | command = "XMAS" | command = "XRSQ" | command = "XRCP" then do; call get_argument (); call ftp_mail_$anonymous_mail (addr (ftp_data), command, argument); end; else if command = "TYPE" then do; call get_argument (); if argument = "A" | argument = "a" then call reply_ok ("type", "ASCII"); else call reply_not_ok ("type"); end; else if command = "BYTE" then do; call get_argument (); if argument = "8" then call reply_ok ("byte size", "8"); else call reply_not_ok ("byte size"); end; else if command = "MODE" then do; call get_argument (); if argument = "S" | argument = "s" then call reply_ok ("transfer mode", "Stream"); else call reply_not_ok ("transfer mode"); end; else if command = "FORM" then do; call get_argument (); if argument = "U" | argument = "u" then call reply_ok ("form", "Unformatted"); else call reply_not_ok ("form"); end; else if command = "STRU" then do; call get_argument (); if argument = "F" | argument = "f" then call reply_ok ("structure", "File"); else call reply_not_ok ("structure"); end; else call ioa_$ioa_switch (ftp_data.iocb_ptr, "504 Command not implemented in Mail Server Process environment: ^a" , command); go to read_command_line; /* this internal procedure establishes defaults in ftp_data including the iocb pointer to be used. */ setup: procedure (iocb_ptr); declare iocb_ptr ptr parameter; call ftp_initialization_$init_ftp_data (addr (ftp_data)); ftp_data.iocb_ptr = iocb_ptr; call ioa_$ioa_switch (ftp_data.iocb_ptr, "230 Mail Server Process ready."); if ^testing then do; call iox_$control (ftp_data.iocb_ptr, "set_editing_chars", addr (editing_chars_structure), (0)); call iox_$modes (ftp_data.iocb_ptr, "can,^erkl,^esc", (""), (0)); end; return; end setup; get_argument: procedure; arg_begin = verify (substr (command_line, command_length + 1, nelemt - command_length - 1), " "); if arg_begin = 0 then arg_begin = nelemt; else arg_begin = arg_begin + command_length; argument = substr (command_line, arg_begin, nelemt - arg_begin); end get_argument; reply_ok: procedure (which, param); declare (which, param) char (*); call ioa_$ioa_switch (ftp_data.iocb_ptr, "200 Default ^a ^a accepted.", which, param); end reply_ok; reply_not_ok: procedure (which); declare which char (*); call ioa_$ioa_switch (ftp_data.iocb_ptr, "506 Non-default ^a ^a not accepted in Mail Server Process Environment.", which, argument); end reply_not_ok; netml_default_handler: procedure (mcptr, cond_name, wcptr, infoptr, continue); declare mcptr ptr, wcptr ptr, infoptr ptr, cond_name char (*), continue bit (1); if cond_name = "finish" then return; if cond_name = "io_error" then goto finnish; if first_time then do; first_time = "0"b; call ioa_$rs ("435 Unexpected fatal error ""^a"".", response_line, response_len, cond_name); call iox_$put_chars (ftp_data.iocb_ptr, addr (response_line), response_len, (0)); if tasking | testing then do; call net_log_ (1, "^a", substr (response_line, 1, response_len - 1)); goto finnish; end; end; call terminate_process_ ("logout", addr (logout_info)); end netml_default_handler; finnish: /* wonderful people those Finns */ end netml_responder_;  ftp_mail_mailer_.pl1 07/17/81 1758.1rew 07/17/81 1540.2 77895 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */ ftp_mail_mailer_: procedure (Destination, Mail_ptr, Code) options (separate_static); /* ftp_mail_mailer_: Interim mail delivery module for network mail systems. */ /* Written by C. Hornig, May 1980. */ dcl ( Destination varying char (*), Mail_ptr ptr, Code fixed bin (35) ) parameter; dcl ( UP init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"), LOW init ("abcdefghijklmnopqrstuvwxyz") ) char (26) static options (constant); dcl (error_table_$id_not_found) fixed bin (35) external; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)), ioa_$rsnnl entry () options (variable), mailbox_$open entry (char (*), char (*), fixed bin, fixed bin (35)), mailbox_$close entry (fixed bin, fixed bin (35)), mailbox_$wakeup_add_index entry (fixed bin, pointer, fixed bin (24), bit (4) aligned, bit (72) aligned, fixed bin (35)), user_info_ entry (character (*), character (*), character (*)), date_time_ entry (fixed bin (71), character (*)), host_id_$number entry (fixed bin (32), character (*), fixed bin (35)), request_id_ entry (fixed bin (71)) returns (character (19)), message_segment_$add_file entry (character (*), character (*), pointer, fixed bin (24), bit (72) aligned, fixed bin (35)); dcl cp ptr static init (null ()); dcl whoptr ptr static init (null ()); dcl xptr ptr; dcl xtext char (1000000) based (xptr); dcl 1 qmi aligned like queue_msg_info; dcl 1 nmf aligned, 2 header like mail_format.header, 2 text char (14); dcl i fixed bin; dcl dest varying char (128) aligned; dcl link_e char (32); dcl link_dir char (168); dcl person varying char (32); dcl mbx_idx fixed bin; dcl code fixed bin (35); dcl validate bit aligned; dcl (addr, after, before, clock, currentsize, index, length, null, pointer, reverse, rtrim, string, substr, translate, unspec) builtin; %page; /* * * * * * * * * * * FTP_MAIL_MAILER_ * * * * * * * * * * */ validate = "0"b; goto common; /* * * * * * * * * * VALIDATE * * * * * * * * * */ validate: entry (Destination, Mail_ptr, Code); validate = "1"b; common: if Mail_ptr = null () then do; /* if there is no mail to send d */ mail_format_ptr = addr (nmf); /* use default parameters */ unspec (nmf) = ""b; end; else mail_format_ptr = Mail_ptr; dest = Destination; if length (Destination) > 5 then /* this might be RFC 780 format */ if translate (substr (Destination, 1, 4), UP, LOW) = "TO:<" then do; dest = substr (before (dest, ">"), 5); /* take the part between the <>'s */ do while (index (dest, ",") > 0); /* reorder the source route */ dest = after (dest, ",") /* A@B,C@D -> C@D@B */ || reverse (before (reverse (before (dest, ",")), "@")); end; end; link_dir, link_e = ""; if index (dest, "@") > 0 then goto forward; /* handle forwarding requests */ call get_link_target (mlsys_data_$mailbox_link_directory, dest || ".mbx", link_dir, link_e, code); /* Maybe it is in the link table */ if code ^= 0 /* try with case mapping if necessary */ then call get_link_target (mlsys_data_$mailbox_link_directory, translate (dest, UP, LOW) || ".mbx", link_dir, link_e, code); if code = 0 then goto got_path; if index (dest, ".") = 0 then do; /* maybe it is Person ID */ if whoptr = null () /* try to see if he is logged in */ then call hcs_$initiate (">system_control_dir", "whotab", "", 0, 0, whoptr, code); if whoptr ^= null () then do i = 1 to whotab.laste; if (whotab.e (i).anon = 0) & (dest = whotab.e (i).person) then do; call ioa_$rsnnl (">udd>^a>^a", link_dir, (0), whotab.e (i).project, dest); link_e = dest || ".mbx"; if (whotab.e (i).active > 0) & (whotab.e (i).proc_type = 1) then goto got_path; ; /* if he is not interactive then there might be a better choice */ end; end; if link_e = "" then do; Code = error_table_$id_not_found; /* nothing logged in */ goto return_to_caller; end; else goto got_path; /* only absentee jobs logged in */ end; person = before (dest, "."); link_dir = ">udd>" || after (dest, ".") || ">" || person; link_e = person || ".mbx"; got_path: if link_dir = ">FORWARD" then do; /* handle case of automatic forwarding */ dest = rtrim (link_e); goto forward; end; call mailbox_$open (link_dir, link_e, mbx_idx, Code); /* normal case */ if Code ^= 0 then goto return_to_caller; call mailbox_$wakeup_add_index (mbx_idx, mail_format_ptr, 36 * currentsize (mail_format), mail_format.wakeup || mail_format.urgent || "0"b || validate, (""b), Code); if Code ^= 0 then goto return_to_caller; if ^validate & ^mail_format.wakeup then do; nmf.version = mail_format_version_3; nmf.sent_from = mail_format.sent_from; nmf.lines = 1; nmf.text_len = length (nmf.text); string (nmf.switches) = ""b; nmf.switches.wakeup, nmf.switches.notify = "1"b; nmf.text = "You have mail."; call mailbox_$wakeup_add_index (mbx_idx, addr (nmf), 36 * currentsize (nmf), "1000"b, (""b), code); end; goto return_to_caller; forward: qmi.foreign_host_name = reverse (before (reverse (link_e), "@")); call host_id_$number (qmi.foreign_host, qmi.foreign_host_name, Code); if Code ^= 0 then goto return_to_caller; if ^validate then do; qmi.foreign_user = reverse (after (reverse (link_e), "@")); call user_info_ (qmi.person, qmi.project, ("")); qmi.dirname = mlsys_data_$pool_directory; qmi.subject = ""; string (qmi.flags) = ""b; qmi.flags.in_use = "1"b; qmi.times_attempted = 0; qmi.to_list, qmi.cc_list = ""; qmi.time_to_send = clock (); call date_time_ (qmi.time_to_send, qmi.date_time); qmi.ename = "send_mail_." || request_id_ (qmi.time_to_send); call hcs_$make_seg (qmi.dirname, qmi.ename, "", 01010b, xptr, Code); /* make the seg to be mailed */ if xptr = null () then goto return_to_caller; substr (xtext, 1, mail_format.text_len) = mail_format.text; call hcs_$set_bc_seg (xptr, 9 * mail_format.text_len, code); call hcs_$terminate_noname (xptr, code); call message_segment_$add_file (mlsys_data_$mailer_directory, "outgoing_mail.ms", addr (qmi), 36 * currentsize (qmi), (""b), Code); if Code ^= 0 then goto return_to_caller; if cp = null () then call hcs_$initiate (mlsys_data_$mailer_directory, "server_com_seg", "", 0, 0, cp, code); if cp ^= null () then call hcs_$wakeup (cp -> net_mailer_com_seg.net_mailer_process_id, cp -> net_mailer_com_seg.mailer_event_channel, 0, (0)); end; goto return_to_caller; return_to_caller: if mbx_idx ^= 0 then call mailbox_$close (mbx_idx, (0)); return; /* * * * * * * * * * * GET_LINK_TARGET * * ** * * * * * * */ get_link_target: procedure (Ldir, Le, Tdir, Te, Code); dcl (Ldir, Le, Tdir, Te) char (*) parameter; dcl Code fixed bin (35); %include status_structures; dcl get_system_free_area_ entry returns (ptr); dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl 1 lkdata aligned like status_branch; status_ptr = addr (lkdata); status_area_ptr = get_system_free_area_ (); call hcs_$status_ (Ldir, Le, 0, status_ptr, status_area_ptr, Code); if Code ^= 0 then return; if status_link.type ^= Link then do; Tdir = Ldir; Te = Le; end; else call expand_pathname_ ((status_pathname), Tdir, Te, Code); free status_pathname; end get_link_target; %page; %include mail_format; %include mlsys_data; %include mlsys_net_mailer_info; %include whotab; end ftp_mail_mailer_; 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