dial_out.pl1 04/24/92 1445.5r w 04/24/92 1438.6 103410 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1991 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ dial_out: procedure options (variable); /* dial_out: make a dial_out connection for a user. */ /* Written by C. Hornig, March 1980. */ /* Modified for installation by C. Hornig, April 1982 */ /* Modified January 1983 by C. Hornig for new features */ /* Modified April 1983 for connect entrypoint. */ /****^ HISTORY COMMENTS: 1) change(91-08-16,Schroth), approve(91-09-09,MCR8247), audit(92-04-24,WAAnderson), install(92-04-24,MR12.5-1012): Added 'force' mode to modes string for -8bit connections. 2) change(91-08-19,JRGray), approve(91-09-09,MCR8247), audit(92-04-24,WAAnderson), install(92-04-24,MR12.5-1012): Modified to note that 'dial_out_' prevents cleanup of profile_ptr after ssu_ takes responsibility for it. (Communications 457) 3) change(91-08-19,JRGray), approve(91-09-09,MCR8247), audit(92-04-24,WAAnderson), install(92-04-24,MR12.5-1012): Modified to add 'force' to the mode string for '-8bit' communication. This allows communication on those connections that don't support 'no_outp' mode. END HISTORY COMMENTS */ dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$io_no_permission fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl com_err_ options (variable); dcl com_err_$suppress_name entry () options (variable); dcl cu_$arg_count_rel entry (fixed bin, ptr, fixed bin (35)); dcl cu_$arg_list_ptr entry returns (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl dial_out_ entry (ptr, fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl alp ptr; dcl dial_not_connect bit (1) aligned; dcl 1 doi aligned like dial_out_info; dcl code fixed bin (35); dcl user_request_length fixed bin (21); dcl user_request_ptr ptr; dcl cleanup condition; dcl (addr, codeptr, index, length, null, rtrim, string, substr) builtin; dcl connect_request char (doi.request_length) based (doi.request_ptr); dcl user_request char (user_request_length) based (user_request_ptr); %page; dial_not_connect = "1"b; doi.command_name = "dial_out"; goto dial; connect: entry options (variable); dial_not_connect = "0"b; doi.command_name = "connect"; goto dial; dial: doi.version = DIAL_OUT_INFO_VERSION_2; doi.cmd_version = "2"; doi.net_iocb = null (); doi.request_table_ptr = null (); doi.request_ptr, doi.profile_ptr, doi.modes_ptr = null (); user_request_ptr = null (); doi.request_length, doi.modes_len = 0; doi.esc_char = "!"; string (doi.flags) = ""b; if ^dial_not_connect then doi.no_startup_sw = "1"b; doi.flags.raw_sw = "1"b; on cleanup call cleaner; if ^dial_not_connect then do; call get_temp_segment_ (doi.command_name, doi.request_ptr, code); if doi.request_ptr = null () then do; call com_err_ (code, doi.command_name, "Getting temp segment."); go to return_to_caller; end; end; alp = cu_$arg_list_ptr (); begin options (non_quick); /* save stack space */ dcl arg char (al) based (ap); dcl ap ptr; dcl al fixed bin (21); dcl nargs fixed bin; dcl i fixed bin; dcl (phone_given, bit8_sw) bit (1) aligned; dcl channel char (32); dcl phone varying char (48); dcl resource varying char (64); dcl atd char (168); dcl dirname char (168); dcl ename char (32); dcl 1 stti aligned like set_term_type_info; call cu_$arg_count_rel (nargs, alp, code); if code ^= 0 then do; call com_err_ (code, doi.command_name); goto return_to_caller; end; channel, phone, stti.name, resource = ""; phone_given, bit8_sw = "0"b; do i = 1 to nargs; call cu_$arg_ptr_rel (i, ap, al, code, alp); if index (arg, "-") = 1 then if (arg = "-raw") | (arg = "-send_cr") | (arg = "-line") then ; else if arg = "-echo" then doi.echo_sw = "1"b; else if arg = "-8bit" then bit8_sw = "1"b; else if (arg = "-escape") | (arg = "-esc") then do; i = i + 1; call cu_$arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then do; call com_err_ (code, doi.command_name, "Missing escape character."); goto return_to_caller; end; if length (arg) ^= 1 then do; call com_err_ (error_table_$bad_arg, doi.command_name, "Escape sequence must be one character."); goto return_to_caller; end; doi.esc_char = arg; end; else if (arg = "-terminal_type") | (arg = "-ttp") then do; i = i + 1; call cu_$arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then do; call com_err_ (code, doi.command_name, "Missing terminal type."); goto return_to_caller; end; stti.name = arg; end; else if (arg = "-resource") | (arg = "-rsc") then do; i = i + 1; call cu_$arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then do; call com_err_ (code, doi.command_name, "Missing resource description."); goto return_to_caller; end; resource = arg; end; else if (arg = "-request") | (arg = "-rq") then do; i = i + 1; call cu_$arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then do; call com_err_ (code, doi.command_name, "Missing request."); goto return_to_caller; end; user_request_ptr = ap; user_request_length = al; end; else if arg = "-modes" then do; i = i + 1; call cu_$arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then do; call com_err_ (code, doi.command_name, "Missing modes."); goto return_to_caller; end; doi.modes_ptr = ap; doi.modes_len = al; end; else if (arg = "-abbrev") | (arg = "-ab") then doi.flags.abbrev_sw = "1"b; else if (arg = "-profile") then do; i = i + 1; call cu_$arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then do; call com_err_ (code, doi.command_name, "Missing profile pathname."); goto return_to_caller; end; call expand_pathname_$add_suffix (arg, "profile", dirname, ename, code); if code ^= 0 then do; call com_err_ (code, doi.command_name, "^a", arg); goto return_to_caller; end; doi.flags.abbrev_sw = "1"b; call hcs_$initiate (dirname, ename, "", 0, 0, doi.profile_ptr, code); if doi.profile_ptr = null () then do; call com_err_ (code, doi.command_name, "^a>^a", dirname, ename); goto return_to_caller; end; end; else if (arg = "-brief") | (arg = "-bf") then doi.flags.brief_sw = "1"b; else if (arg = "-no_start_up") | (arg = "-nsu") | (arg = "-ns") then doi.flags.no_startup_sw = "1"b; else do; call com_err_ (error_table_$badopt, doi.command_name, "^a", arg); goto return_to_caller; end; else if /* case */ channel = "" then channel = arg; else if ^phone_given then do; phone = arg; phone_given = "1"b; end; else do; call com_err_ (error_table_$wrong_no_of_args, doi.command_name, "^a", arg); goto return_to_caller; end; end; if ^doi.raw_sw then doi.echo_sw = "1"b; if channel = "" then do; call com_err_$suppress_name (0, doi.command_name, "Usage: ^a CHANNEL {DEST} {-control_args}", doi.command_name); goto return_to_caller; end; phone = requote_string_ ((phone)); if ^dial_not_connect then do; doi.request_length = 3; connect_request = "ec "; if phone_given then do; doi.request_length = 3 + length (phone); substr (connect_request, 4) = phone; end; else do; doi.request_length = 3 + length (rtrim (channel)); substr (connect_request, 4) = channel; end; if user_request_ptr ^= null () then do; /* add user command to this */ doi.request_length = doi.request_length + 1; substr (connect_request, doi.request_length, 1) = ";"; doi.request_length = doi.request_length + user_request_length; substr (connect_request, doi.request_length - user_request_length + 1) = user_request; end; end; else do; doi.request_ptr = user_request_ptr; doi.request_length = user_request_length; end; call ioa_$rsnnl ("tty_ ^a^[ -destination ^a^;^s^]^[ -resource ^a^;^s^]", atd, (0), channel, phone_given, phone, (resource ^= ""), requote_string_ ((resource))); call iox_$attach_name ("dial_out." || unique_chars_ (""b), doi.net_iocb, atd, codeptr (dial_out), code); if code ^= 0 then do; call com_err_ (code, doi.command_name, "Attaching ^a.", atd); goto return_to_caller; end; call iox_$open (doi.net_iocb, Stream_input_output, "0"b, code); if code ^= 0 then do; call com_err_ (code, doi.command_name, "Opening ^a.", atd); goto return_to_caller; end; if stti.name ^= "" then do; stti.version = stti_version_1; string (stti.flags) = ""b; stti.flags.set_modes, stti.flags.send_initial_string = "1"b; call iox_$control (doi.net_iocb, "set_term_type", addr (stti), code); end; else do; call iox_$modes (doi.net_iocb, "force,init,rawi,rawo,breakall,ctl_char,^ll,fulldpx", (""), code); end; if code ^= 0 then do; call com_err_ (code, doi.command_name, "Setting terminal type."); goto return_to_caller; end; if bit8_sw then do; call iox_$modes (doi.net_iocb, "force,8bit,no_outp", (""), code); end; end; call dial_out_ (addr (doi), code); if code = error_table_$io_no_permission then do; if ^doi.flags.brief_sw then call ioa_ ("dial_out: Connection closed."); end; else if code ^= 0 then call com_err_ (code, doi.command_name); return_to_caller: call cleaner; return; cleaner: procedure; if doi.net_iocb ^= null () then do; call iox_$close (doi.net_iocb, code); call iox_$detach_iocb (doi.net_iocb, code); call iox_$destroy_iocb (doi.net_iocb, code); doi.net_iocb = null (); end; /* COM 457: Note that dial_out_ sets profile_ptr to null() after ssu_ takes responsibility for it */ if doi.profile_ptr ^= null () then do; call hcs_$terminate_noname (doi.profile_ptr, code); doi.profile_ptr = null (); end; if ^dial_not_connect then call release_temp_segment_ (doi.command_name, doi.request_ptr, code); return; end cleaner; %page; %include dial_out_info; %include iox_dcls; %include iox_modes; %include set_term_type_info; end dial_out;  dial_out_.pl1 04/24/92 1445.5r w 04/24/92 1439.4 82431 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1991 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ dial_out_: procedure (Dial_out_info_ptr, Code); /* dial_out: make a dial_out connection for a user. */ /* Written by C. Hornig, March 1980. */ /* Modified for installation, April 1982, by C. Hornig */ /* Modified January 1983 by C. Hornig to fix many bugs */ /* Modified March 1983 by K. Loepere to fix more bugs and enhance */ /****^ HISTORY COMMENTS: 1) change(91-07-15,Oke), approve(91-09-09,MCR8247), audit(92-04-24,WAAnderson), install(92-04-24,MR12.5-1012): Changed to zero doi local do_info structure in initialization. 2) change(91-08-19,JRGray), approve(91-09-09,MCR8247), audit(92-04-24,WAAnderson), install(92-04-24,MR12.5-1012): Set profile_ptr to null preventing 'dial_out' from cleaning it up after ssu_ becomes responsible for it. (Communications 457) END HISTORY COMMENTS */ dcl Code fixed bin (35) parameter; dcl Dial_out_info_ptr ptr parameter; dcl do_request_table_$do_request_table_ external; dcl ssu_request_tables_$standard_requests external; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl video_data_$terminal_iocb ptr external static; dcl continue_to_signal_ entry (fixed bin (35)); dcl cu_$arg_list_ptr entry returns (ptr); dcl cu_$caller_ptr entry () returns (ptr); dcl cu_$cl entry (bit (36) aligned); dcl cu_$get_cl_intermediary entry (entry); dcl cu_$set_cl_intermediary entry (entry); dcl dial_out_modes_$set entry (ptr, char (*), fixed bin (35)); dcl dial_out_util_$call_out entry (ptr, entry, ptr); dcl dial_out_util_$interaction_loop entry (ptr, bit (1) aligned, bit (1) aligned); dcl dial_out_util_$process_line_status entry (ptr); dcl dial_out_util_$reset_do_modes entry (ptr); dcl dial_out_util_$revert_fo entry (ptr); dcl dial_out_util_$set_do_modes entry (ptr); dcl get_process_id_ entry () returns (bit (36) aligned); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)); dcl ioa_ entry () options (variable); dcl ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35)); dcl ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl ssu_$execute_start_up entry () options (variable); dcl ssu_$get_temp_segment entry (ptr, char (*), ptr); dcl ssu_$print_blast entry (ptr, ptr, fixed bin, char (*), fixed bin (35)); dcl ssu_$set_abbrev_info entry (ptr, ptr, ptr, bit (1) aligned); dcl ssu_$set_ec_search_list entry (ptr, char (32)); dcl ssu_$set_ec_suffix entry (ptr, char (32)); dcl based_atd varying char (256) based; dcl based_modes char (doi.modes_len) based (doi.modes_ptr); dcl code fixed bin (35); dcl 1 hangup_proc_data aligned, 2 entry_var variable entry (ptr), 2 data_ptr ptr, 2 prior fixed bin; dcl 1 doi aligned like do_info; dcl in_video bit (1) aligned; dcl net_input_buff char (2048); dcl str_to_match char (1024); dcl (cleanup, quit) condition; dcl (addr, length, null, string, unspec) builtin; %page; /* find out initial modes, options, etc. */ Code = 0; if (Dial_out_info_ptr -> dial_out_info.version ^= "doinfo_0") & (Dial_out_info_ptr -> dial_out_info.version ^= "doinfo_1") & (Dial_out_info_ptr -> dial_out_info.version ^= DIAL_OUT_INFO_VERSION_2) then do; Code = error_table_$unimplemented_version; return; end; dop = addr (doi); unspec (doi) = ""b; doi.ci = Dial_out_info_ptr -> dial_out_info; if doi.ci.version = "doinfo_0" then doi.ci.cmd_version = ""; if (doi.ci.version = "doinfo_0") | (doi.ci.version = "doinfo_1") then do; doi.ci.modes_ptr = null (); doi.ci.modes_len = 0; end; doi.version = doi.ci.cmd_version || "/2a"; doi.abort_label = return_to_caller; doi.abort_code = 0; doi.sci_ptr = null (); doi.fo_iocbp = null (); doi.temp_seg_p = null (); doi.match_length = 0; string (doi.flags) = ""b; doi.flags.echo_mode = "1"b; in_video = video_data_$terminal_iocb ^= null (); if doi.ci.modes_ptr ^= null () then do; call dial_out_modes_$set (dop, based_modes, doi.abort_code); if doi.abort_code ^= 0 then goto doi.abort_label; end; doi.old_modes = ""; call iox_$modes (iox_$user_input, "", doi.old_modes, code); doi.cmd_ptr = null (); call cu_$get_cl_intermediary (doi.saved_cl_intermediary); on cleanup call cleaner; call ssu_$create_invocation (doi.ci.command_name, (doi.version), addr (doi), doi.ci.request_table_ptr, ">doc>subsystem>dial_out", doi.sci_ptr, doi.abort_code); if doi.abort_code ^= 0 then goto return_to_caller; call ssu_$add_request_table (doi.sci_ptr, addr (do_request_table_$do_request_table_), 2, doi.abort_code); if doi.abort_code ^= 0 then goto return_to_caller; call ssu_$add_request_table (doi.sci_ptr, addr (ssu_request_tables_$standard_requests), 3, doi.abort_code); if doi.abort_code ^= 0 then goto return_to_caller; call ssu_$print_blast (doi.sci_ptr, cu_$caller_ptr (), 1, "", code); call ssu_$set_abbrev_info (doi.sci_ptr, doi.ci.profile_ptr, null (), (doi.ci.flags.abbrev_sw)); Dial_out_info_ptr -> dial_out_info.profile_ptr = null(); /* COM 457: it's now completely ssu_'s responsibility */ call ssu_$set_ec_search_list (doi.sci_ptr, "dial_out"); call ssu_$set_ec_suffix (doi.sci_ptr, "dial_out"); call ssu_$get_temp_segment (doi.sci_ptr, "work_area", doi.temp_seg_p); doi.cmd_buff_len = sys_info$max_seg_size * 4; call ssu_$get_temp_segment (doi.sci_ptr, "command_area", doi.cmd_ptr); doi.match_string_p = addr (str_to_match); doi.match_length = 0; doi.match_max_length = length (str_to_match); doi.net_input_buff_ptr = addr (net_input_buff); doi.net_input_buff_len = length (net_input_buff); doi.net_input_last_char_filled = 0; doi.net_input_last_char_output = 0; on quit begin; if doi.ci.flags.quit_sw then do; call iox_$control (doi.ci.net_iocb, "interrupt", null (), doi.abort_code); if doi.abort_code ^= 0 then goto return_to_caller; end; else call continue_to_signal_ (doi.abort_code); end; doi.my_cl_intermediary = do_cl_intermediary; call cu_$set_cl_intermediary (doi.my_cl_intermediary); hangup_proc_data.entry_var = process_hangup; hangup_proc_data.data_ptr = addr (doi); hangup_proc_data.prior = 1; call iox_$control (doi.ci.net_iocb, "hangup_proc", addr (hangup_proc_data), code); if ^doi.ci.flags.brief_sw then call ioa_ ("Ready on ^a...", doi.ci.net_iocb -> iocb.attach_descrip_ptr -> based_atd); call dial_out_util_$process_line_status (dop); call dial_out_util_$reset_do_modes (dop); /* undo mode set above for running start_up, request */ if ^doi.ci.flags.no_startup_sw then call ssu_$execute_start_up (doi.sci_ptr, code); if doi.ci.request_ptr ^= null () then call ssu_$execute_line (doi.sci_ptr, doi.ci.request_ptr, doi.ci.request_length, code); call dial_out_util_$set_do_modes (dop); %page; /* The main work lies in util_. This is so the interaction loop may , be reentered (recursively) from the wait request. */ call dial_out_util_$interaction_loop (dop, "0"b, "0"b); return_to_caller: call cleaner; Code = doi.abort_code; return; %page; /* * * * * * * * * * CLEANER * * * * * * * * * */ cleaner: procedure; call cu_$set_cl_intermediary (doi.saved_cl_intermediary); call dial_out_util_$reset_do_modes (dop); if doi.raw_sw then if ^in_video then call iox_$control (iox_$user_input, "send_initial_string", null (), code); /* we need to reset tabs, etc. that foreign screwed up - would be nice if this wasn't necessary */ call dial_out_util_$revert_fo (addr (doi)); if doi.sci_ptr ^= null () then do; call ssu_$destroy_invocation (doi.sci_ptr); end; doi.cmd_ptr = null (); return; end cleaner; /* * * * * * * * * * DO_CL_INTERMEDIARY * * * * * * * * * * */ do_cl_intermediary: procedure (Flags) options (non_quick); dcl Flags bit (36) aligned parameter; call dial_out_util_$call_out (dop, cu_$cl, cu_$arg_list_ptr ()); /* This gets the modes right */ return; end do_cl_intermediary; /* * * * * * * * * * PROCESS_HANGUP * * * * * * * * * * */ process_hangup: procedure (Data_ptr); dcl code fixed bin (35); dcl Data_ptr ptr parameter; call hcs_$wakeup (get_process_id_ (), Data_ptr -> event_call_info.data_ptr -> do_info.net_rs.ev_chn, 0, code); return; %include event_call_info; end process_hangup; %page; %include dial_out_invocation; %include iocb; %include iox_dcls; end dial_out_;  dial_out_modes_.pl1 07/18/83 0949.3r w 07/13/83 0949.3 31725 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ dial_out_modes_$set: procedure (Dop, Modes, Code); /* Written January 1983 by C. Hornig */ dcl Dop ptr parameter; dcl Modes char (*) parameter; dcl Code fixed bin (35) parameter; dcl error_table_$bad_mode fixed bin (35) ext static; dcl error_table_$bad_mode_value fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl get_user_free_area_ entry () returns (ptr); dcl mode_string_$parse entry (char (*), ptr, ptr, fixed bin (35)); dcl i fixed bin; dcl (set_raw, set_echo, set_lfecho) bit (1) aligned; dcl cleanup condition; dcl null builtin; /* * * * * * * * * * SET * * * * * * * * * */ dop = Dop; set_raw = do_info.raw_sw; set_echo = do_info.echo_sw; set_lfecho = do_info.lfecho_sw; mode_string_info_ptr = null (); on cleanup begin; if mode_string_info_ptr ^= null () then free mode_string_info; end; call mode_string_$parse (Modes, get_user_free_area_ (), mode_string_info_ptr, Code); if Code ^= 0 then return; if mode_string_info.version ^= mode_string_info_version_2 then call abort (error_table_$unimplemented_version); do i = 1 to mode_string_info.number; if mode_string_info.modes (i).version ^= mode_value_version_3 then call abort (error_table_$unimplemented_version); if /* case */ mode_string_info.modes (i).mode_name = "echo" then if mode_string_info.modes (i).boolean_valuep then set_echo = mode_string_info.modes (i).boolean_value; else call abort (error_table_$bad_mode_value); else if mode_string_info.modes (i).mode_name = "raw" then if mode_string_info.modes (i).boolean_valuep then set_raw = mode_string_info.modes (i).boolean_value; else call abort (error_table_$bad_mode_value); else if mode_string_info.modes (i).mode_name = "echo_lf" then if mode_string_info.modes (i).boolean_valuep then set_lfecho = mode_string_info.modes (i).boolean_value; else call abort (error_table_$bad_mode_value); else if mode_string_info.modes (i).mode_name = "send_lf" then if mode_string_info.modes (i).boolean_valuep then do_info.flags.send_lf_sw = mode_string_info.modes (i).boolean_value; else call abort (error_table_$bad_mode_value); else if mode_string_info.modes (i).mode_name = "quit" then if mode_string_info.modes (i).boolean_valuep then do_info.flags.quit_sw = mode_string_info.modes (i).boolean_value; else call abort (error_table_$bad_mode_value); else if mode_string_info.modes (i).mode_name = "line" then if mode_string_info.modes (i).boolean_valuep then do_info.flags.no_breakall_sw = mode_string_info.modes (i).boolean_value; else call abort (error_table_$bad_mode_value); else call abort (error_table_$bad_mode); end; punt: free mode_string_info; do_info.ci.raw_sw = set_raw; do_info.ci.echo_sw = set_echo; do_info.ci.lfecho_sw = set_lfecho; return; /* * * * * * * * * * ABORT * * * * * * * * * */ abort: procedure (Error); dcl Error fixed bin (35) parameter; Code = Error; goto punt; end abort; %page; %include dial_out_invocation; %include mode_string_info; end dial_out_modes_$set;  dial_out_sl_default_.cds 02/16/88 1502.4r w 02/16/88 1409.5 26928 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ dial_out_sl_default_: procedure (); /* automatic */ declare code fixed binary (35); declare wdir char (168); declare 1 cdsa aligned like cds_args; declare 1 lists aligned, 2 dial_out, 3 name_count fixed binary, 3 path_count fixed binary, 3 names (1) char (32), 3 paths (3) like search_path; /* based */ declare 1 search_path based, 2 type fixed binary, 2 pathname char (168); /* builtin */ declare addr builtin; declare hbound builtin; declare null builtin; declare rtrim builtin; declare size builtin; declare unspec builtin; /* entry */ declare com_err_ entry options (variable); declare create_data_segment_ entry (pointer, fixed binary (35)); declare get_wdir_ entry () returns (char (168)); %include sl_info; %include cds_args; /* program */ lists.dial_out.name_count = hbound (lists.dial_out.names, 1); lists.dial_out.path_count = hbound (lists.dial_out.paths, 1); lists.dial_out.names (1) = "dial_out"; lists.dial_out.paths (1).type = WORKING_DIR; lists.dial_out.paths (1).pathname = "-working_dir"; lists.dial_out.paths (2).type = UNEXPANDED_PATH; lists.dial_out.paths (2).pathname = ">udd>[user project]>dial_out_dir"; lists.dial_out.paths (3).type = ABSOLUTE_PATH; lists.dial_out.paths (3).pathname = ">site>dial_out_dir"; unspec (cdsa) = ""b; cdsa.sections (1).p = addr (lists); cdsa.sections (1).len = size (lists); cdsa.sections (1).struct_name = "lists"; cdsa.sections (2).p = null; cdsa.sections (2).struct_name = ""; cdsa.seg_name = "dial_out_sl_default_"; cdsa.exclude_array_ptr = null; cdsa.switches.have_text = "1"b; call create_data_segment_ (addr (cdsa), code); if code ^= 0 then do; call com_err_ (code, "dial_out_sl_default_"); return; end; wdir = get_wdir_ (); call add_search_names (lists.dial_out.names (*)); return; add_search_names: proc (name_array); declare name_array dimension (*) char (32) aligned parameter; declare hbound builtin; declare lbound builtin; declare error_table_$segnamedup fixed bin (35) ext static; declare hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); declare i fixed bin; declare extra_name char (32); do i = lbound (name_array, 1) to hbound (name_array, 1); extra_name = rtrim (name_array (i)) || ".search"; call hcs_$chname_file (wdir, "dial_out_sl_default_", "", extra_name, code); if code ^= 0 then if code ^= error_table_$segnamedup then call com_err_ (code, "dial_out_sl_default_", "Adding name ^a", extra_name); end; return; end add_search_names; end dial_out_sl_default_;  dial_out_util_.pl1 04/24/92 1445.5r w 04/24/92 1439.1 216540 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1991 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ dial_out_util_: procedure; /* Written January 1983 by C. Hornig */ /* Modified March 1983 by K. Loepere to fix bugs, enhance for waiting */ /* Modified September 1983 by R.J.C. Kissel to send lines to the remote */ /* system wth their terminators in one put_chars call. (Mostly for 6M). */ /* Modified December 1983 by B. Margolin to change reset_do_modes to just call iox_$modes and iox_$control, rather than calling set_modes (which would set some tty modes improperly for a reset), and remove the minor optimization in set_modes which is no longer valid. */ /****^ HISTORY COMMENTS: 1) change(91-07-15,Oke), approve(91-09-09,MCR8247), audit(92-04-24,WAAnderson), install(92-04-24,MR12.5-1012): To setup a length for substr's of input_buffer in escape and special character processing. Previously this did not account for num_chars_read and thus indexed into uninitialized parts of the automatic variable input_buffer, with amusing results. 2) change(91-08-15,Schroth), approve(91-09-09,MCR8247), audit(92-04-24,WAAnderson), install(92-04-24,MR12.5-1012): Added cleanup handler to interaction_loop entry to reset the wait alarm timer when unwinding. END HISTORY COMMENTS */ dcl Active_function bit (1) aligned; dcl Arg_list ptr parameter; dcl Code fixed bin (35) parameter; dcl Dop ptr parameter; dcl Data_ptr ptr parameter; dcl Entry variable entry parameter; dcl Nelem fixed bin (21) parameter; dcl Silent bit (1) aligned parameter; dcl Waiting bit (1) aligned parameter; dcl CR char (1) static options (constant) init (" "); dcl NL char (1) static options (constant) init (" "); dcl cleanup condition; dcl program_interrupt condition; dcl quit condition; dcl active_function bit (1) aligned init ("0"b); dcl active_len_before_quotes fixed bin (21); /* see if final quotes pair */ dcl active_result char (do_info.active_result_max_len) based (do_info.active_result_ptr) var; dcl cmd_buff char (do_info.cmd_buff_len) based (do_info.cmd_ptr); /* accumulated stuff to either send out or execute */ dcl cmd_len fixed bin (21); dcl code fixed bin (35); dcl escape_seen bit (1) aligned; /* last char was an escape char */ dcl 1 ev_msg aligned like event_wait_info; dcl in_command bit (1) aligned; /* now reading a command */ dcl need_to_echo_command bit (1) aligned; /* have processed the command character */ dcl need_to_check_net bit (1) aligned; /* chars may be present at net */ dcl need_to_check_term bit (1) aligned; /* chars may be present at term */ dcl net_input_buff char (do_info.net_input_buff_len) based (do_info.net_input_buff_ptr); dcl silent bit (1) aligned init ("0"b); /* don't print stuff from net */ dcl 1 term_rs aligned like do_info.net_rs; dcl 1 wait_list aligned, 2 count fixed bin, 2 pad fixed bin, 2 ev_chn (2) fixed bin (71); dcl waiting bit (1) aligned init ("0"b); /* in mode ignoring terminal input waiting for something from net */ dcl error_table_$line_status_pending fixed bin (35) ext static; dcl error_table_$timeout fixed bin (35) ext static; dcl com_err_ entry () options (variable); dcl cu_$arg_list_ptr entry () returns (ptr); dcl cu_$generate_call entry (entry, ptr); dcl cu_$set_cl_intermediary entry (entry); dcl get_user_free_area_ entry returns (ptr); dcl ioa_$nnl entry () options (variable); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl timer_manager_$alarm_call entry (fixed bin (71), bit (2), entry, ptr); dcl timer_manager_$reset_alarm_call entry (entry); dcl requote_string_$quote_string entry (char (*)) returns (char (*)); dcl (addcharno, addr, divide, index, length, min, mod, null, rtrim, substr) builtin; /* * * * * * * * * SEND_CHARS * * * * * * * * * * */ send_chars: entry (Dop, Data_ptr, Nelem, Code); dop = Dop; call send (Data_ptr, Nelem, Code); return; /* * * * * * * * * * SEND_NL * * * * * * * * * */ send_nl: entry (Dop, Code); dop = Dop; call send (addr (CR), 1, Code); if Code ^= 0 then return; if do_info.flags.send_lf_sw then do; call send (addr (NL), 1, Code); if Code ^= 0 then return; end; return; /* * * * * * * * * * SEND * * * * * * * * */ send: procedure (Data_ptr, Nelem, Code); dcl Code fixed bin (35) parameter; dcl Data_ptr ptr parameter; dcl Nelem fixed bin (21) parameter; rewrite: call iox_$put_chars (do_info.ci.net_iocb, Data_ptr, Nelem, Code); if Code = error_table_$line_status_pending then do; call line_status; goto rewrite; end; return; end send; /* * * * * * * * * * PROCESS_LINE_STATUS * * * * * * * * * * */ process_line_status: entry (Dop); dop = Dop; call line_status; return; /* * * * * * * * * * SET_DO_MODES * * * * * * * * * */ set_do_modes: entry (Dop); dop = Dop; call set_modes (do_info.ci.raw_sw, do_info.ci.echo_sw, do_info.ci.lfecho_sw); return; /* * * * * * * * * * RESET_DO_MODES * * * * * * * * * */ reset_do_modes: entry (Dop); dop = Dop; call iox_$modes (iox_$user_input, do_info.old_modes, (""), (0)); call iox_$control (iox_$user_input, "printer_on", null (), (0)); return; /* * * * * * * * * LINE_STATUS * * * * * * * * * * */ line_status: procedure; dcl ls_data bit (72) aligned; dcl code fixed bin (35); call iox_$control (do_info.ci.net_iocb, "line_status", addr (ls_data), code); call get_modes; return; end line_status; /* * * * * * * * * GET_MODES * * * * * * * * * */ get_modes: procedure; dcl code fixed bin (35); dcl 1 ftd aligned like foreign_terminal_data; dcl i fixed bin; ftd.version = FOREIGN_TERMINAL_DATA_VERSION_1; ftd.area_ptr = get_user_free_area_ (); call iox_$control (do_info.ci.net_iocb, "get_foreign_terminal_data", addr (ftd), code); if code ^= 0 then return; mode_string_info_ptr = ftd.mode_string_info_ptr; if mode_string_info.version = mode_string_info_version_2 then do; do_info.flags.echo_sw = "0"b; do i = 1 to mode_string_info.number; /* process each mode */ mode_value_ptr = addr (mode_string_info.modes (i)); if mode_value.version = mode_value_version_3 then do; if /* case */ ((mode_value.mode_name = "echoplex") | (mode_value.mode_name = "echo")) & mode_value.flags.boolean_valuep & mode_value.flags.boolean_value then do_info.ci.flags.echo_sw = "1"b; else if (mode_value.mode_name = "lfecho") & mode_value.flags.boolean_valuep then do_info.ci.flags.lfecho_sw = mode_value.flags.boolean_value; else if (mode_value.mode_name = "breakall") & mode_value.flags.boolean_valuep then do_info.ci.flags.no_breakall_sw = ^mode_value.flags.boolean_value; end; end; end; call set_modes (do_info.ci.raw_sw, do_info.ci.echo_sw, do_info.ci.lfecho_sw); free mode_string_info; return; %include mode_string_info; end get_modes; /* * * * * * * * * * SET_MODES * * * * * * * * * */ set_modes: procedure (Raw, Echo, Lfecho); dcl (Raw, Echo, Lfecho) bit (1) unaligned parameter; dcl code fixed bin (35); call iox_$modes (iox_$user_input, do_info.old_modes, (""), code); call iox_$control (iox_$user_input, "printer_on", null (), code); if Raw then call iox_$modes (iox_$user_input, "force,rawi,rawo,^replay,^polite,^prefixnl", (""), code); if ^do_info.no_breakall_sw then do; call iox_$modes (iox_$user_input, "breakall", (""), code); if ^Lfecho | ^Echo then call iox_$modes (iox_$user_input, "^lfecho", (""), code); end; if ^Echo then do; call iox_$modes (iox_$user_input, "force,^tabecho,^crecho", (""), code); call iox_$control (iox_$user_input, "printer_off", null (), code); end; do_info.raw_mode = Raw; do_info.echo_mode = Echo; do_info.lfecho_mode = Lfecho; return; end set_modes; %page; interaction_loop: entry (Dop, Waiting, Active_function); /* This is the main loop that looks for chars coming from either end and normally just sends them to the other end. The terminals chars are examined for escape sequences. */ dop = Dop; waiting = Waiting; active_function, silent = Active_function; if active_function then do; do_info.active_result_max_len = do_info.active_result_max_len - 1; /* leave room for final quote */ active_result = """"; end; if ^waiting then on program_interrupt /* set only for main usage, not wait */ begin; call set_do_modes (dop); /* just in case */ call cu_$set_cl_intermediary (do_info.my_cl_intermediary); call ioa_$nnl ("^1aInput: ", do_info.ci.esc_char); call terminal_input ("1"b); waiting = "0"b; goto reenter_interaction_loop; end; on cleanup begin; if waiting & do_info.time_out > 0 then call timer_manager_$reset_alarm_call (abort_wait); end; reenter_interaction_loop: if waiting then if do_info.match_length > 0 then /* did what he wants already come */ if net_input_found () then goto interaction_done; in_command, need_to_echo_command, escape_seen = "0"b; need_to_check_net, need_to_check_term = "1"b; /* set everything to give us a chance to see what's there */ cmd_len = 0; term_rs.ev_chn = 0; do_info.abort_code = 0; do while ("1"b); if need_to_check_net then do; call iox_$control (do_info.ci.net_iocb, "read_status", addr (do_info.net_rs), code); if code ^= 0 then do_info.net_rs.data_available = "1"b; if do_info.net_rs.data_available then call net_input; else need_to_check_net = "0"b; end; if need_to_check_term & ^waiting then do; call iox_$control (iox_$user_input, "read_status", addr (term_rs), code); if code ^= 0 then term_rs.data_available = "1"b; if term_rs.data_available then call terminal_input ("0"b); else do; need_to_check_term = "0"b; if need_to_echo_command then do; call reset_do_modes (dop); if ^do_info.ci.flags.echo_sw then call ioa_$nnl ("^1a^a", do_info.ci.esc_char, substr (cmd_buff, 1, cmd_len)); need_to_echo_command = "0"b; end; end; end; if (^need_to_check_term | waiting) & ^need_to_check_net then do; /* if we're convinced no one has something for us, wait */ wait_list.ev_chn (1) = do_info.net_rs.ev_chn; if (term_rs.ev_chn ^= 0) & ^waiting then do; wait_list.ev_chn (2) = term_rs.ev_chn; wait_list.count = 2; end; else wait_list.count = 1; if waiting & do_info.time_out > 0 then call timer_manager_$alarm_call ((do_info.time_out), "11"b, abort_wait, null ()); call ipc_$block (addr (wait_list), addr (ev_msg), do_info.abort_code); if waiting & do_info.time_out > 0 then call timer_manager_$reset_alarm_call (abort_wait); if do_info.abort_code ^= 0 then goto return_to_caller; if ev_msg.channel_index = 1 then need_to_check_net = "1"b; else need_to_check_term = "1"b; end; end; interaction_done: if active_function then do; /* make sure that the final quotes pair correctly (Normally, an extra quote is needed at the end to properly requote the result. We may need to fiddle, though, for this to come out right if we overflowed the end before.) */ do_info.active_result_max_len = do_info.active_result_max_len + 1; /* give room for one more quote */ active_len_before_quotes = length (rtrim (active_result, """")); if active_len_before_quotes = 0 then /* all quotes */ if mod (length (active_result), 2) ^= 0 then active_result = active_result || """"; /* pair up */ else ; else if mod (length (active_result) - active_len_before_quotes, 2) = 0 then active_result = active_result || """"; else ; end; return; abort_wait: proc (mc_ptr, name, wc_ptr, data_ptr) options (non_quick); /* must be non_quick since it is called (non-locally) through an entry variable) */ dcl (mc_ptr, wc_ptr, data_ptr) ptr; dcl name char (*); do_info.abort_code = error_table_$timeout; goto interaction_done; end; /* * * * * * * * * PROCESS_NET_INPUT * * * * * * * * * */ process_net_input: entry (Dop, Silent); dop = Dop; silent = Silent; call net_input; return; net_input: procedure; dcl half_size fixed bin; /* amount to scroll down char matching area */ dcl num_received fixed binary (21) automatic; if do_info.net_input_last_char_filled = do_info.net_input_buff_len then do; /* we filled matching area to end; scroll down last half over first half to get more space and so new high half flows from end of old high half - also update pointer to last char therein we matched on a wait */ half_size = divide (do_info.net_input_buff_len, 2, 17); /* since the chars we scroll over can't be seen again or matched - output them */ if do_info.net_input_last_char_output < half_size then call output_net_input (half_size - do_info.net_input_last_char_output); substr (net_input_buff, 1, half_size) = substr (net_input_buff, half_size + 1, half_size); do_info.net_input_last_char_filled = half_size; net_input_last_char_output = net_input_last_char_output - half_size; end; call iox_$get_chars (do_info.ci.net_iocb, addcharno (addr (net_input_buff), do_info.net_input_last_char_filled), do_info.net_input_buff_len - do_info.net_input_last_char_filled, num_received, do_info.abort_code); /* read as much as still fits in area */ if do_info.abort_code = error_table_$line_status_pending then do; call process_line_status (dop); return; end; if (num_received = 0) & (do_info.abort_code ^= 0) then goto return_to_caller; if num_received > 0 then do; do_info.net_input_last_char_filled = do_info.net_input_last_char_filled + num_received; if waiting /* see if we have read desired chars */ then if net_input_found () then goto interaction_done; else ; else call output_net_input (do_info.net_input_last_char_filled - do_info.net_input_last_char_output); end; return; end net_input; net_input_found: proc () returns (bit (1) aligned); dcl match_string char (do_info.match_length) based (do_info.match_string_p); dcl matched_pos fixed bin; /* net_input very nicely keeps a running script of what came from the net. He keeps scrolling this down, by halves, in the net_input_buff. Thus, we can do an index to see if the string came in (from the marked point at which we last looked). This will succeed as long as the string being searched for does not exceed half the size of net_input_buff. */ if do_info.match_length = 0 /* any chars satisfy */ then return ("1"b); else do; matched_pos = index ( substr (net_input_buff, do_info.net_input_last_char_output + 1, do_info.net_input_last_char_filled - do_info.net_input_last_char_output), match_string); /* search only in chars after what matched a previous wait desire */ if matched_pos > 0 then do; call output_net_input (do_info.match_length + matched_pos - 1); return ("1"b); end; end; return ("0"b); end; output_net_input: proc (amount); /* take desired chars and send to all appropriate places */ dcl amount fixed bin (21); if amount <= 0 then return; if active_function then do; active_result = active_result || requote_string_$quote_string (substr (net_input_buff, do_info.net_input_last_char_output + 1, amount)) ; end; if ^silent then do; /* not in send_file discard mode or active function */ call iox_$put_chars (iox_$user_output, addcharno (addr (net_input_buff), do_info.net_input_last_char_output), amount, do_info.abort_code); if do_info.abort_code ^= 0 then goto return_to_caller; end; if do_info.fo_iocbp ^= null () then do; /* file out in progress */ call iox_$put_chars (do_info.fo_iocbp, addcharno (addr (net_input_buff), do_info.net_input_last_char_output), amount, code); if code ^= 0 then do; call com_err_ (code, do_info.ci.command_name, "Error in file_output, reverting."); call revert_fo (addr (do_info)); end; end; do_info.net_input_last_char_output = do_info.net_input_last_char_output + amount; end; terminal_input: procedure (Force_get_line); dcl Force_get_line bit (1) aligned parameter; dcl c char (1) aligned; /* previous char examining */ dcl code fixed bin (35); dcl fragment_len fixed bin (21); /* amount of input to add to command or output */ dcl indx fixed bin (21); /* start of string being considered */ dcl input_buffer char (128); dcl next_char fixed bin (21); /* pos rel to indx of next char to consider */ dcl next_whatever fixed bin (21); /* pos rel to indx of nl, cr, being looked for */ dcl num_bytes_read fixed bin (21); /* * * * * * * * * * * * * * * * * * * * * * * * */ num_bytes_read = 0; if Force_get_line | ^do_info.raw_mode then call iox_$get_line (iox_$user_input, addr (input_buffer), length (input_buffer), num_bytes_read, do_info.abort_code); else call iox_$get_chars (iox_$user_input, addr (input_buffer), length (input_buffer), num_bytes_read, do_info.abort_code); if (do_info.abort_code ^= 0) & (num_bytes_read = 0) then goto do_info.abort_label; if num_bytes_read = 0 then return; indx = 1; if escape_seen then do; /* last char of previous buffer was escape */ escape_seen = "0"b; fragment_len = 1; c = substr (input_buffer, indx, 1); if c = do_info.ci.esc_char then call insert; /* two esc's in a row make only one */ else if in_command then do; call switch; /* leave command */ call insert; /* add char to regular input */ end; else if ^((c = CR) | (do_info.lfecho_mode & do_info.echo_mode & (c = NL))) then do; call switch; /* start command */ call insert; end; else ; /* esc CR is null command */ indx = 2; /* first char used */ end; /* loop, grabbing strings up to break chars (esc, nl, etc) */ do while (indx <= num_bytes_read); /* look for an interesting char (esc, CR,...) */ next_char = index (substr (input_buffer, indx, num_bytes_read - indx + 1), do_info.ci.esc_char); if next_char = 0 then next_char = num_bytes_read - indx + 1; /* last char is considered interesting if no esc, nl... */ next_whatever = index (substr (input_buffer, indx, num_bytes_read - indx + 1), CR); if next_whatever = 0 then next_whatever = num_bytes_read - indx + 1; next_char = min (next_char, next_whatever); if in_command | (do_info.lfecho_mode & do_info.echo_mode) then do; /* NL is interesting only in a command or when modes say it is */ next_whatever = index (substr (input_buffer, indx, num_bytes_read - indx + 1), NL); if next_whatever = 0 then next_whatever = num_bytes_read - indx + 1; next_char = min (next_char, next_whatever); end; c = substr (input_buffer, indx + next_char - 1, 1); if /* case */ c = do_info.ci.esc_char then do; fragment_len = next_char - 1; call insert; /* chars up to esc go to appropriate buffer */ indx = indx + fragment_len + 1; /* -> after esc */ if indx > num_bytes_read then escape_seen = "1"b; /* remember to look at in next buffer */ else do; fragment_len = 1; c = substr (input_buffer, indx, 1); if c = do_info.ci.esc_char then call insert; /* two esc's in a row make only one */ else if in_command then do; call switch; /* leave command */ call insert; /* add char to regular input */ end; else if ^((c = CR) | (do_info.lfecho_mode & do_info.echo_mode & (c = NL))) then do; call switch; /* start command */ call insert; /* add char to it */ end; else ; /* esc CR is null command */ indx = indx + 1; end; end; else if (c = CR) | (c = NL /* if we thought they were interesting before */) then do; fragment_len = next_char - 1; call insert; /* add chars to appropriate buffer */ indx = indx + fragment_len + 1; /* -> after CR */ if in_command then call switch; /* CR ends command */ else do; /* Send a line with its terminator. */ call insert_char (CR); if do_info.flags.send_lf_sw then call insert_char (NL); call transmit_buffer (); end; end; else do; /* must be last char in buffer */ fragment_len = next_char; call insert; /* add to buffer */ indx = indx + fragment_len; end; end; if ^in_command & (cmd_len > 0) then call transmit_buffer (); return; switch: procedure (); dcl this_cmd_len fixed bin (21); if in_command then do; /* end to command detected - prepare to execute */ this_cmd_len = cmd_len; cmd_len = 0; if need_to_echo_command & ^do_info.ci.flags.echo_sw then call ioa_$nnl ("^1a^a", do_info.ci.esc_char, substr (cmd_buff, 1, this_cmd_len)); in_command, need_to_echo_command = "0"b; call cmd_proc (do_info.sci_ptr, do_info.cmd_ptr, this_cmd_len, code); end; else do; /* begin start of command */ call transmit_buffer (); in_command, need_to_echo_command = "1"b; end; return; end switch; insert: procedure (); /* add chars to output buffer */ substr (cmd_buff, cmd_len + 1, fragment_len) = substr (input_buffer, indx, fragment_len); cmd_len = cmd_len + fragment_len; end insert; insert_char: proc (Char); dcl Char char (1) parameter; substr (cmd_buff, cmd_len + 1, 1) = Char; cmd_len = cmd_len + 1; return; end insert_char; /* * * * * * * * * * TRANSMIT_BUFFER * * * * * * * * * */ transmit_buffer: /* send characters to the remote */ procedure; call send_chars (dop, addr (cmd_buff), cmd_len, do_info.abort_code); if do_info.abort_code ^= 0 then goto do_info.abort_label; cmd_len = 0; return; end transmit_buffer; /* * * * * * * * * * COMMAND_PROC * * * * * * * * * */ cmd_proc: procedure (Sci_ptr, Cmd_ptr, Cmd_len, Code) options (non_quick); /* get a standard argument list */ dcl (Cmd_ptr, Sci_ptr) ptr parameter; dcl Cmd_len fixed bin (21) parameter; dcl Code fixed bin (35) parameter; call call_out (dop, ssu_$execute_line, cu_$arg_list_ptr ()); need_to_check_term = "1"b; need_to_check_net = "1"b; /* who knows what happened while we were gone */ call output_net_input (do_info.net_input_last_char_filled - do_info.net_input_last_char_output); /* after possible wait request, flush what wasn't grabbed */ return; end cmd_proc; end terminal_input; /* * * * * * * * * * REVERT_FO * * * * * * * * */ revert_fo: entry (Dop); dop = Dop; if do_info.fo_iocbp = null then return; call iox_$close (do_info.fo_iocbp, code); call iox_$detach_iocb (do_info.fo_iocbp, code); call iox_$destroy_iocb (do_info.fo_iocbp, code); do_info.fo_iocbp = null; return; /* * * * * * * * * * CALL_OUT * * * * * * * * * */ call_out: entry (Dop, Entry, Arg_list); dop = Dop; on cleanup begin; call set_do_modes (dop); call cu_$set_cl_intermediary (do_info.my_cl_intermediary); end; on quit system; call reset_do_modes (dop); call cu_$set_cl_intermediary (do_info.saved_cl_intermediary); call cu_$generate_call (Entry, Arg_list); call set_do_modes (dop); call cu_$set_cl_intermediary (do_info.my_cl_intermediary); return; return_to_caller: return; %page; %include dial_out_invocation; %include event_wait_info; %include foreign_terminal_data; %include iox_dcls; end dial_out_util_;  do_request_table_.alm 11/05/86 1220.3r w 11/04/86 1038.4 17865 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** name do_request_table_ " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " Common request table for dial_out_. " " Written by C. Hornig, April 1982. " Modified January 1983 by C. Hornig to remove rdn and rdf. " Modified February 1983 by C. Hornig to add wait. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " include ssu_request_macros begin_table do_request_table_ request escape, do_requests_$escape_request, (esc), (Change the escape character.), flags.allow_command request file_output, do_requests_$file_output_request, (fo), (Start copying output to a file.), flags.allow_command request interrupt, do_requests_$interrupt_request, (int,break,brk,ip), (Send an interrupt signal.), flags.allow_command request modes, do_requests_$modes_request, (), (Set dial_out modes.), flags.allow_both request quit, do_requests_$quit_request, (q), (Leave subsystem.), flags.allow_command request revert_output, do_requests_$revert_output_request, (ro), (Finish copying output to a file.), flags.allow_command request send, do_requests_$send_request, (), (Send arguments as if typed.), flags.allow_command request send_file, do_requests_$send_file_request, (sf), (Send file as if typed.), flags.allow_command request switch_name, do_requests_$switch_name_request, (), (Return name of I/O switch.), flags.allow_both request wait, do_requests_$wait_request, (), (Wait for data from foreign system.), flags.allow_both " Tailor the standard table a bit. unknown_request (ready_off,rdf) unknown_request (ready_on,rdn) end_table do_request_table_ end  do_requests_.pl1 04/24/92 1445.5r w 04/24/92 1438.8 132444 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1991 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ do_requests_: procedure; /* Written April 1982 by C. Hornig */ /* Modified 11 September 1982 by Richard Lamson to fix line_status problem in send and other requests. */ /* Modified January 1983 by C. Hornig to reorganize functions */ /* Modified March 1983 by K. Loepere so that send_file won't overflow FNP input buffer with remote echo and so wait request can wait for a string and so wait works in dial_out ecs */ /****^ HISTORY COMMENTS: 1) change(91-08-15,Schroth), approve(91-09-09,MCR8247), audit(92-04-24,WAAnderson), install(92-04-24,MR12.5-1012): Added -inhibit_error/-no_inhibit_error to wait request to inhibit active function failure on timeouts. If -inhibit_error is used with -timeout, whatever was received prior the the timer runout will be returned as the value of the active request. END HISTORY COMMENTS */ dcl (Sci_ptr, Do_ptr) ptr parameter; dcl NL char (1) static options (constant) init (" "); dcl SP char (1) static options (constant) init (" "); dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$bad_conversion fixed bin (35) ext static; dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$inconsistent fixed bin (35) ext static; dcl error_table_$line_status_pending fixed bin (35) ext static; dcl error_table_$long_record fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$short_record fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl cu_$set_cl_intermediary entry (entry); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl dial_out_modes_$set entry (ptr, char (*), fixed bin (35)); dcl dial_out_util_$interaction_loop entry (ptr, bit (1) aligned, bit (1) aligned); dcl dial_out_util_$process_line_status entry (ptr); dcl dial_out_util_$process_net_input entry (ptr, bit (1) aligned); dcl dial_out_util_$reset_do_modes entry (ptr); dcl dial_out_util_$send_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl dial_out_util_$send_nl entry (ptr, fixed bin (35)); dcl dial_out_util_$set_do_modes entry (ptr); dcl ioa_ entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl requote_string_ entry (char (*)) returns (char (*)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl abort_on_timeout bit (1) aligned; /* timeout causes wait to abort */ dcl af_sw bit (1) aligned; /* request called as active request */ dcl arg_num fixed bin; dcl buff char (512); /* reading from send file */ dcl code fixed bin (35); dcl i fixed bin; dcl iocbp ptr; dcl nargs fixed bin; dcl new_line bit (1) aligned; /* on end of wait str */ dcl nin fixed bin (21); /* chars read from send file */ dcl long_rec bit (1) aligned; /* didn't read whole line from file */ dcl path_found bit (1) aligned; /* found path arg in send_file request */ dcl silent bit (1) aligned; /* discard foreign chars during transfer */ dcl arg char (al) based (ap); /* standard argument stuff */ dcl al fixed bin (21); dcl ap ptr; dcl path char (path_len) based (path_ptr); /* pathname for send_file request */ dcl path_len fixed bin (21); dcl path_ptr ptr; dcl str_to_match_area char (do_info.match_max_length) based (do_info.match_string_p); dcl val varying char (val_len) based (val_ptr); /* active request value */ dcl val_len fixed bin (21); dcl val_ptr ptr; dcl cleanup condition; dcl (addr, codeptr, index, length, null, substr) builtin; %page; /* * * * * * * * * * QUIT * * * * * * * * * */ quit_request: entry (Sci_ptr, Do_ptr); dop = Do_ptr; do_info.abort_code = 0; goto do_info.abort_label; /* * * * * * * * * * INTERRUPT * * * * * * * * * */ interrupt_request: entry (Sci_ptr, Do_ptr); dop = Do_ptr; try_interrupt_request_again: call iox_$control (do_info.ci.net_iocb, "interrupt", null (), code); if code = error_table_$line_status_pending then do; call dial_out_util_$process_line_status (dop); go to try_interrupt_request_again; end; if code ^= 0 then call ssu_$abort_line (Sci_ptr, code); return; /* * * * * * * * * * MODES * * * * * * * * * */ modes_request: entry (Sci_ptr, Do_ptr); dop = Do_ptr; call ssu_$return_arg (Sci_ptr, nargs, af_sw, val_ptr, val_len); if af_sw then do; call ioa_$rsnnl ("^[^^^]raw,^[^^^]echo,^[^^^]send_lf,^[^^^]echo_lf,^[^^^]quit,^[^^^]line", val, (0), ^do_info.flags.raw_sw, ^do_info.flags.echo_sw, ^do_info.flags.send_lf_sw, ^do_info.flags.lfecho_sw, ^do_info.flags.quit_sw, ^do_info.flags.no_breakall_sw); end; if nargs < 1 then do; if ^af_sw then call ioa_ ("^[^^^]raw,^[^^^]echo,^[^^^]send_lf,^[^^^]echo_lf,^[^^^]quit,^[^^^]line", ^do_info.flags.raw_sw, ^do_info.flags.echo_sw, ^do_info.flags.send_lf_sw, ^do_info.flags.lfecho_sw, ^do_info.flags.quit_sw, ^do_info.flags.no_breakall_sw); return; end; if nargs > 1 then call ssu_$abort_line (Sci_ptr, error_table_$wrong_no_of_args); call ssu_$arg_ptr (Sci_ptr, 1, ap, al); call dial_out_modes_$set (dop, arg, code); if code ^= 0 then call ssu_$abort_line (Sci_ptr, code); return; /* * * * * * * * * * ESCAPE * * * * * * * * * */ escape_request: entry (Sci_ptr, Do_ptr); dop = Do_ptr; call ssu_$return_arg (Sci_ptr, nargs, af_sw, val_ptr, val_len); if af_sw then do; val = requote_string_ ((do_info.esc_char)); end; if nargs < 1 & ^af_sw then do; call ioa_ ("^1a", do_info.esc_char); return; end; if nargs > 1 then call ssu_$abort_line (Sci_ptr, error_table_$wrong_no_of_args); call ssu_$arg_ptr (Sci_ptr, 1, ap, al); if length (arg) = 1 then do_info.esc_char = arg; else call ssu_$abort_line (Sci_ptr, error_table_$bad_arg, "^a", arg); return; /* * * * * * * * * * SEND * * * * * * * * * */ send_request: entry (Sci_ptr, Do_ptr); dop = Do_ptr; call ssu_$arg_count (Sci_ptr, nargs); if nargs < 1 then return; call ssu_$arg_ptr (Sci_ptr, 1, ap, al); call dial_out_util_$send_chars (dop, ap, al, code); if code ^= 0 then bad_write: call ssu_$abort_line (Sci_ptr, code, "Writing."); do i = 2 to nargs; call dial_out_util_$send_chars (dop, addr (SP), 1, code); if code ^= 0 then goto bad_write; call ssu_$arg_ptr (Sci_ptr, i, ap, al); call dial_out_util_$send_chars (dop, ap, al, code); if code ^= 0 then goto bad_write; end; return; /* * * * * * * * * * SEND_FILE_REQUEST * * * * * * * * * */ send_file_request: entry (Sci_ptr, Do_ptr); dop = Do_ptr; silent = "1"b; call ssu_$arg_count (Sci_ptr, nargs); if nargs < 1 | nargs > 2 then call ssu_$abort_line (Sci_ptr, 0, "Usage: send_file path {-display_input}"); path_found = "0"b; do i = 1 to nargs; call ssu_$arg_ptr (Sci_ptr, i, ap, al); if arg = "-display_input" | arg = "-dsin" then silent = "0"b; else if arg = "-no_display_input" | arg = "-ndsin" then silent = "1"b; else if index (arg, "-") = 1 then call ssu_$abort_line (Sci_ptr, error_table_$bad_arg, "^a", arg); else do; if path_found then call ssu_$abort_line (Sci_ptr, 0, "More than one path specified. ^a", arg); path_found = "1"b; path_ptr = ap; path_len = al; end; end; iocbp = null (); on cleanup begin; call reset_do_state; call clean_iocb (iocbp); end; call iox_$attach_name ("do.send_file." || unique_chars_ (""b), iocbp, "vfile_ " || path, codeptr (send_file_request), code); if code ^= 0 then call ssu_$abort_line (Sci_ptr, code, "Attaching vfile_ ^a", path); call iox_$open (iocbp, Stream_input, "0"b, code); if code ^= 0 then call ssu_$abort_line (Sci_ptr, code, "Opening vfile_ ^a", path); call set_do_state; /* coming here reset do state, we need it back so process_net_input works */ do while ("1"b); call iox_$control (do_info.ci.net_iocb, "read_status", addr (do_info.net_rs), code); /* get incoming (echo?) */ if code ^= 0 then do_info.net_rs.data_available = "1"b; if do_info.net_rs.data_available then call dial_out_util_$process_net_input (dop, silent); long_rec = "0"b; call iox_$get_line (iocbp, addr (buff), length (buff), nin, code); if (code = error_table_$long_record) | (code = error_table_$short_record) then long_rec = "1"b; else if (nin = 0) & (code = error_table_$end_of_info) then goto done_send_file; else if code ^= 0 then call ssu_$abort_line (Sci_ptr, code, "Reading from ^a", path); else nin = nin - 1; /* trim NL */ call dial_out_util_$send_chars (dop, addr (buff), nin, code); if code ^= 0 then call ssu_$abort_line (Sci_ptr, code, "Writing.", path); if ^long_rec then do; call dial_out_util_$send_nl (dop, code); if code ^= 0 then call ssu_$abort_line (Sci_ptr, code, "Writing NL.", path); end; end; done_send_file: call reset_do_state; call clean_iocb (iocbp); return; /* * * * * * * * * * SWITCH_NAME_REQUEST * * * * * * * * */ switch_name_request: entry (Sci_ptr, Do_ptr); dop = Do_ptr; call ssu_$return_arg (Sci_ptr, nargs, af_sw, val_ptr, val_len); if nargs ^= 0 then call ssu_$abort_line (Sci_ptr, 0, "Usage: switch_name"); if af_sw then val = do_info.ci.net_iocb -> iocb.name; else call ioa_ ("^a", do_info.ci.net_iocb -> iocb.name); return; /* * * * * * * * * * * FILE_OUTPUT_REQUEST * * * * * * * * * * */ file_output_request: entry (Sci_ptr, Do_ptr); dop = Do_ptr; call ssu_$arg_count (Sci_ptr, nargs); if nargs ^= 1 then call ssu_$abort_line (Sci_ptr, 0, "Usage: file_output path"); if do_info.fo_iocbp ^= null () then call ssu_$abort_line (Sci_ptr, 0, "file_output already in progress."); call ssu_$arg_ptr (Sci_ptr, 1, ap, al); on cleanup call clean_iocb (do_info.fo_iocbp); call iox_$attach_name ("do.file_output." || unique_chars_ (""b), do_info.fo_iocbp, "vfile_ " || arg || " -extend", codeptr (file_output_request), code); if code ^= 0 then call ssu_$abort_line (Sci_ptr, code, "Attaching vfile_ ^a.", arg); call iox_$open (do_info.fo_iocbp, Stream_output, "1"b, code); if code ^= 0 then call ssu_$abort_line (Sci_ptr, code, "Opening vfile_ ^a.", arg); return; /* * * * * * * * * * REVERT_OUTPUT_REQUEST * * * * * * * * * * */ revert_output_request: entry (Sci_ptr, Do_ptr); dop = Do_ptr; call ssu_$arg_count (Sci_ptr, nargs); if nargs ^= 0 then call ssu_$abort_line (Sci_ptr, 0, "Usage: revert_output"); if do_info.fo_iocbp = null () then call ssu_$abort_line (Sci_ptr, 0, "No file_output in progress."); call clean_iocb (do_info.fo_iocbp); return; /* * * * * * * * * * WAIT * * * * * * * * * * */ wait_request: entry (Sci_ptr, Do_ptr); dop = Do_ptr; call ssu_$return_arg (Sci_ptr, nargs, af_sw, val_ptr, val_len); do_info.time_out = 0; abort_on_timeout = "1"b; new_line = "0"b; do_info.match_length = 0; do arg_num = 1 to nargs; call ssu_$arg_ptr (Sci_ptr, arg_num, ap, al); if arg = "-timeout" | arg = "-tm" then do; if arg_num = nargs then call ssu_$abort_line (Sci_ptr, error_table_$noarg, "Timeout value."); else do; arg_num = arg_num + 1; call ssu_$arg_ptr (Sci_ptr, arg_num, ap, al); do_info.time_out = cv_dec_check_ (arg, code); if code ^= 0 | do_info.time_out < 1 then call ssu_$abort_line (Sci_ptr, error_table_$bad_conversion, "^a", arg); end; end; else if arg = "-no_timeout" | arg = "-ntm" then do_info.time_out = 0; else if arg = "-nl" then new_line = "1"b; else if arg = "-nnl" then new_line = "0"b; else if arg = "-no_inhibit_error" | arg = "-nihe" then abort_on_timeout = "1"b; else if arg = "-inhibit_error" | arg = "-ihe" then abort_on_timeout = "0"b; else if substr (arg, 1, 1) = "-" then call ssu_$abort_line (Sci_ptr, error_table_$bad_arg, "^a", arg); else do; if length (arg) > do_info.match_max_length - 1 /* room for NL */ then call ssu_$abort_line (Sci_ptr, 0, "Wait string too long; max is ^d.", do_info.match_max_length - 1);/* arg too long to print with error */ else do; substr (str_to_match_area, 1, length (arg)) = arg; do_info.match_length = length (arg); end; end; end; if ^abort_on_timeout & do_info.time_out = 0 then call ssu_$abort_line (Sci_ptr, error_table_$inconsistent, "The use of -inhibit_error requires that -timeout be used as well."); if new_line then do; do_info.match_length = do_info.match_length + 1; substr (str_to_match_area, do_info.match_length, 1) = NL; end; if af_sw then do; do_info.active_result_ptr = val_ptr; do_info.active_result_max_len = val_len; val = ""; end; on cleanup call reset_do_state; call set_do_state; /* get back do state so that interaction loop works (it was reset on its way into here */ call dial_out_util_$interaction_loop (dop, "1"b, af_sw); /* do normal net stuff 'til condition met */ if do_info.abort_code ^= 0 then if ^af_sw | abort_on_timeout then call ssu_$abort_line (Sci_ptr, do_info.abort_code); call reset_do_state; return; %page; /* * * * * * * * * * CLEAN_IOCB * * * * * * * * * * * */ clean_iocb: procedure (Iocbp); dcl code fixed bin (35); dcl Iocbp ptr parameter; if Iocbp ^= null () then do; call iox_$close (Iocbp, code); call iox_$detach_iocb (Iocbp, code); call iox_$destroy_iocb (Iocbp, code); Iocbp = null (); end; return; end clean_iocb; reset_do_state: proc; call dial_out_util_$reset_do_modes (dop); call cu_$set_cl_intermediary (do_info.saved_cl_intermediary); return; end; set_do_state: proc; call dial_out_util_$set_do_modes (dop); call cu_$set_cl_intermediary (do_info.my_cl_intermediary); return; end; %page; %include dial_out_invocation; %include iocb; %include iox_dcls; %include iox_modes; end do_requests_; 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